mirror of
https://github.com/github/semantic.git
synced 2024-11-24 08:54:07 +03:00
Merge pull request #1249 from github/simpler-monolithic-syntax
Simpler monolithic syntax
This commit is contained in:
Rob Rix
GitHub
commit
c7bdff56c1
@ -14,7 +14,7 @@ import Term
|
||||
type DiffF f annotation = FreeF (TermF f (Both annotation)) (Patch (Term f annotation))
|
||||
type Diff f annotation = Free (TermF f (Both annotation)) (Patch (Term f annotation))
|
||||
|
||||
type SyntaxDiff leaf fields = Diff (Syntax leaf) (Record fields)
|
||||
type SyntaxDiff fields = Diff Syntax (Record fields)
|
||||
|
||||
diffSum :: (Foldable f, Functor f) => (Patch (Term f annotation) -> Int) -> Diff f annotation -> Int
|
||||
diffSum patchCost diff = sum $ fmap patchCost diff
|
||||
|
||||
@ -25,7 +25,7 @@ structure.
|
||||
|
||||
The example below adds a new field to the `Record` fields.
|
||||
-}
|
||||
indexedTermAna :: [leaf] -> Term (Syntax leaf) (Record '[NewField, Range, Category])
|
||||
indexedTermAna :: [Text] -> Term Syntax (Record '[NewField, Range, Category])
|
||||
indexedTermAna childrenLeaves = ana coalgebra (indexedTerm childrenLeaves)
|
||||
where
|
||||
coalgebra term = (NewField :. (extract term)) :< unwrap term
|
||||
@ -43,7 +43,7 @@ structure to a new shape.
|
||||
|
||||
The example below adds a new field to the `Record` fields.
|
||||
-}
|
||||
indexedTermCata :: [leaf] -> Term (Syntax leaf) (Record '[NewField, Range, Category])
|
||||
indexedTermCata :: [Text] -> Term Syntax (Record '[NewField, Range, Category])
|
||||
indexedTermCata childrenLeaves = cata algebra (indexedTerm childrenLeaves)
|
||||
where
|
||||
algebra :: Functor f => CofreeF f (Record t) (Cofree f (Record (NewField : t))) -> Cofree f (Record (NewField : t))
|
||||
@ -82,7 +82,7 @@ stringToTermAna "indexed" =>
|
||||
the new cofree `Indexed` structure, resulting in a expansion of all possible
|
||||
string terms.
|
||||
-}
|
||||
stringToTermAna :: String -> Term (Syntax String) (Record '[Range, Category])
|
||||
stringToTermAna :: Text -> Term Syntax (Record '[Range, Category])
|
||||
stringToTermAna = ana coalgebra
|
||||
where
|
||||
coalgebra representation = case representation of
|
||||
@ -95,7 +95,7 @@ Catamorphism -- construct a list of Strings from a recursive Term structure.
|
||||
The example below shows how to tear down a recursive Term structure into a list
|
||||
of String representation.
|
||||
-}
|
||||
termToStringCata :: Term (Syntax String) (Record '[Range, Category]) -> [String]
|
||||
termToStringCata :: Term Syntax (Record '[Range, Category]) -> [Text]
|
||||
termToStringCata = cata algebra
|
||||
where
|
||||
algebra term = case term of
|
||||
@ -123,7 +123,7 @@ Example Usage:
|
||||
stringTermHylo "indexed" => ["indexed", "leaf1", "leaf2", "leaf3"]
|
||||
|
||||
-}
|
||||
stringTermHylo :: String -> [String]
|
||||
stringTermHylo :: Text -> [Text]
|
||||
stringTermHylo = hylo algebra coalgebra
|
||||
where
|
||||
algebra term = case term of
|
||||
@ -177,7 +177,7 @@ Final shape:
|
||||
]
|
||||
|
||||
-}
|
||||
termPara :: Term (Syntax String) (Record '[Range, Category]) -> [(Term (Syntax String) (Record '[Range, Category]), String)]
|
||||
termPara :: Term Syntax (Record '[Range, Category]) -> [(Term Syntax (Record '[Range, Category]), Text)]
|
||||
termPara = para algebra
|
||||
where
|
||||
algebra term = case term of
|
||||
|
||||
@ -32,7 +32,7 @@ Example (from GHCi):
|
||||
|
||||
-}
|
||||
|
||||
leafTermF :: leaf -> TermF (Syntax leaf) (Record '[Range, Category]) b
|
||||
leafTermF :: Text -> TermF Syntax (Record '[Range, Category]) b
|
||||
leafTermF leaf = (Range 1 10 :. Category.MethodCall :. Nil) :< Leaf leaf
|
||||
|
||||
{-
|
||||
@ -57,11 +57,11 @@ Example (from GHCi):
|
||||
> Leaf "example"
|
||||
|
||||
-}
|
||||
leafTerm :: leaf -> Cofree (Syntax leaf) (Record '[Range, Category])
|
||||
leafTerm :: Text -> Cofree Syntax (Record '[Range, Category])
|
||||
leafTerm = cofree . leafTermF
|
||||
|
||||
indexedTermF :: [leaf] -> TermF (Syntax leaf) (Record '[Range, Category]) (Term (Syntax leaf) (Record '[Range, Category]))
|
||||
indexedTermF :: [Text] -> TermF Syntax (Record '[Range, Category]) (Term Syntax (Record '[Range, Category]))
|
||||
indexedTermF leaves = (Range 1 10 :. Category.MethodCall :. Nil) :< Indexed (leafTerm <$> leaves)
|
||||
|
||||
indexedTerm :: [leaf] -> Term (Syntax leaf) (Record '[Range, Category])
|
||||
indexedTerm :: [Text] -> Term Syntax (Record '[Range, Category])
|
||||
indexedTerm leaves = cofree $ indexedTermF leaves
|
||||
|
||||
@ -23,9 +23,9 @@ import Term
|
||||
|
||||
|
||||
-- | Diff two terms recursively, given functions characterizing the diffing.
|
||||
diffTerms :: (Eq leaf, Hashable leaf, HasField fields Category)
|
||||
=> Both (SyntaxTerm leaf fields) -- ^ A pair of terms representing the old and new state, respectively.
|
||||
-> SyntaxDiff leaf fields
|
||||
diffTerms :: HasField fields Category
|
||||
=> Both (SyntaxTerm fields) -- ^ A pair of terms representing the old and new state, respectively.
|
||||
-> SyntaxDiff fields
|
||||
diffTerms = decoratingWith getLabel (diffTermsWith algorithmWithTerms comparableByCategory)
|
||||
|
||||
-- | Diff two terms by decorating with feature vectors computed using the supplied labelling algebra, and stripping the feature vectors from the resulting diff.
|
||||
@ -55,16 +55,16 @@ diffTermsWith refine comparable (Join (a, b)) = runFreer decompose (diff a b)
|
||||
Replace a b -> pure (replacing a b)
|
||||
|
||||
-- | Compute the label for a given term, suitable for inclusion in a _p_,_q_-gram.
|
||||
getLabel :: HasField fields Category => TermF (Syntax leaf) (Record fields) a -> (Category, Maybe leaf)
|
||||
getLabel :: HasField fields Category => TermF Syntax (Record fields) a -> (Category, Maybe Text)
|
||||
getLabel (h :< t) = (Info.category h, case t of
|
||||
Leaf s -> Just s
|
||||
_ -> Nothing)
|
||||
|
||||
|
||||
-- | Construct an algorithm to diff a pair of terms.
|
||||
algorithmWithTerms :: SyntaxTerm leaf fields
|
||||
-> SyntaxTerm leaf fields
|
||||
-> Algorithm (SyntaxTerm leaf fields) (SyntaxDiff leaf fields) (SyntaxDiff leaf fields)
|
||||
algorithmWithTerms :: SyntaxTerm fields
|
||||
-> SyntaxTerm fields
|
||||
-> Algorithm (SyntaxTerm fields) (SyntaxDiff fields) (SyntaxDiff fields)
|
||||
algorithmWithTerms t1 t2 = case (unwrap t1, unwrap t2) of
|
||||
(Indexed a, Indexed b) ->
|
||||
annotate . Indexed <$> byRWS a b
|
||||
|
||||
@ -36,7 +36,7 @@ languageForType mediaType = case mediaType of
|
||||
".py" -> Just Python
|
||||
_ -> Nothing
|
||||
|
||||
toVarDeclOrAssignment :: HasField fields Category => Term (S.Syntax Text) (Record fields) -> Term (S.Syntax Text) (Record fields)
|
||||
toVarDeclOrAssignment :: HasField fields Category => Term S.Syntax (Record fields) -> Term S.Syntax (Record fields)
|
||||
toVarDeclOrAssignment child = case unwrap child of
|
||||
S.Indexed [child', assignment] -> cofree $ setCategory (extract child) VarAssignment :< S.VarAssignment [child'] assignment
|
||||
S.Indexed [child'] -> cofree $ setCategory (extract child) VarDecl :< S.VarDecl [child']
|
||||
@ -44,22 +44,22 @@ toVarDeclOrAssignment child = case unwrap child of
|
||||
S.VarAssignment _ _ -> child
|
||||
_ -> toVarDecl child
|
||||
|
||||
toVarDecl :: HasField fields Category => Term (S.Syntax Text) (Record fields) -> Term (S.Syntax Text) (Record fields)
|
||||
toVarDecl :: HasField fields Category => Term S.Syntax (Record fields) -> Term S.Syntax (Record fields)
|
||||
toVarDecl child = cofree $ setCategory (extract child) VarDecl :< S.VarDecl [child]
|
||||
|
||||
toTuple :: Term (S.Syntax Text) (Record fields) -> [Term (S.Syntax Text) (Record fields)]
|
||||
toTuple :: Term S.Syntax (Record fields) -> [Term S.Syntax (Record fields)]
|
||||
toTuple child | S.Indexed [key,value] <- unwrap child = [cofree (extract child :< S.Pair key value)]
|
||||
toTuple child | S.Fixed [key,value] <- unwrap child = [cofree (extract child :< S.Pair key value)]
|
||||
toTuple child | S.Leaf c <- unwrap child = [cofree (extract child :< S.Comment c)]
|
||||
toTuple child = pure child
|
||||
|
||||
toPublicFieldDefinition :: HasField fields Category => [SyntaxTerm Text fields] -> Maybe (S.Syntax Text (SyntaxTerm Text fields))
|
||||
toPublicFieldDefinition :: HasField fields Category => [SyntaxTerm fields] -> Maybe (S.Syntax (SyntaxTerm fields))
|
||||
toPublicFieldDefinition children = case break (\x -> category (extract x) == Identifier) children of
|
||||
(prev, [identifier, assignment]) -> Just $ S.VarAssignment (prev ++ [identifier]) assignment
|
||||
(_, [_]) -> Just $ S.VarDecl children
|
||||
_ -> Nothing
|
||||
|
||||
toInterface :: HasField fields Category => [SyntaxTerm Text fields] -> Maybe (S.Syntax Text (SyntaxTerm Text fields))
|
||||
toInterface :: HasField fields Category => [SyntaxTerm fields] -> Maybe (S.Syntax (SyntaxTerm fields))
|
||||
toInterface (id : rest) = case break (\x -> category (extract x) == Other "object_type") rest of
|
||||
(clauses, [body]) -> Just $ S.Interface id clauses (toList (unwrap body))
|
||||
_ -> Nothing
|
||||
|
||||
@ -10,8 +10,8 @@ import Term
|
||||
termAssignment
|
||||
:: Source -- ^ The source of the term.
|
||||
-> Category -- ^ The category for the term.
|
||||
-> [ SyntaxTerm Text DefaultFields ] -- ^ The child nodes of the term.
|
||||
-> Maybe (S.Syntax Text (SyntaxTerm Text DefaultFields)) -- ^ The resulting term, in Maybe.
|
||||
-> [ SyntaxTerm DefaultFields ] -- ^ The child nodes of the term.
|
||||
-> Maybe (S.Syntax (SyntaxTerm DefaultFields)) -- ^ The resulting term, in Maybe.
|
||||
termAssignment _ _ _ = Nothing
|
||||
|
||||
|
||||
|
||||
@ -10,8 +10,8 @@ import Term
|
||||
termAssignment
|
||||
:: Source -- ^ The source of the term.
|
||||
-> Category -- ^ The category for the term.
|
||||
-> [ SyntaxTerm Text DefaultFields ] -- ^ The child nodes of the term.
|
||||
-> Maybe (S.Syntax Text (SyntaxTerm Text DefaultFields)) -- ^ The resulting term, in Maybe.
|
||||
-> [ SyntaxTerm DefaultFields ] -- ^ The child nodes of the term.
|
||||
-> Maybe (S.Syntax (SyntaxTerm DefaultFields)) -- ^ The resulting term, in Maybe.
|
||||
termAssignment source category children = case (category, children) of
|
||||
(Module, [moduleName]) -> Just $ S.Module moduleName []
|
||||
(Import, [importName]) -> Just $ S.Import importName []
|
||||
|
||||
@ -12,8 +12,8 @@ import Term
|
||||
termAssignment
|
||||
:: Source -- ^ The source of the term.
|
||||
-> Category -- ^ The category for the term.
|
||||
-> [ SyntaxTerm Text DefaultFields ] -- ^ The child nodes of the term.
|
||||
-> Maybe (S.Syntax Text (SyntaxTerm Text DefaultFields)) -- ^ The resulting term, in Maybe.
|
||||
-> [ SyntaxTerm DefaultFields ] -- ^ The child nodes of the term.
|
||||
-> Maybe (S.Syntax (SyntaxTerm DefaultFields)) -- ^ The resulting term, in Maybe.
|
||||
termAssignment _ category children
|
||||
= case (category, children) of
|
||||
(ArgumentPair, [ k, v ] ) -> Just $ S.Pair k v
|
||||
|
||||
@ -11,8 +11,8 @@ import Term
|
||||
termAssignment
|
||||
:: Source -- ^ The source of the term.
|
||||
-> Category -- ^ The category for the term.
|
||||
-> [ SyntaxTerm Text DefaultFields ] -- ^ The child nodes of the term.
|
||||
-> Maybe (S.Syntax Text (SyntaxTerm Text DefaultFields)) -- ^ The resulting term, in Maybe.
|
||||
-> [ SyntaxTerm DefaultFields ] -- ^ The child nodes of the term.
|
||||
-> Maybe (S.Syntax (SyntaxTerm DefaultFields)) -- ^ The resulting term, in Maybe.
|
||||
termAssignment _ category children =
|
||||
case (category, children) of
|
||||
(Assignment, [ identifier, value ]) -> Just $ S.Assignment identifier value
|
||||
|
||||
@ -48,14 +48,14 @@ data Parser term where
|
||||
-> Assignment ast grammar (Term (Union fs) (Record Location)) -- ^ An assignment from AST onto 'Term's.
|
||||
-> Parser (Term (Union fs) (Record Location)) -- ^ A parser producing 'Term's.
|
||||
-- | A tree-sitter parser.
|
||||
TreeSitterParser :: Ptr TS.Language -> Parser (SyntaxTerm Text DefaultFields)
|
||||
TreeSitterParser :: Ptr TS.Language -> Parser (SyntaxTerm DefaultFields)
|
||||
-- | A parser for 'Markdown' using cmark.
|
||||
MarkdownParser :: Parser (AST CMark.NodeType)
|
||||
-- | A parser which will parse any input 'Source' into a top-level 'Term' whose children are leaves consisting of the 'Source's lines.
|
||||
LineByLineParser :: Parser (SyntaxTerm Text DefaultFields)
|
||||
LineByLineParser :: Parser (SyntaxTerm DefaultFields)
|
||||
|
||||
-- | Return a 'Language'-specific 'Parser', if one exists, falling back to the 'LineByLineParser'.
|
||||
parserForLanguage :: Maybe Language -> Parser (SyntaxTerm Text DefaultFields)
|
||||
parserForLanguage :: Maybe Language -> Parser (SyntaxTerm DefaultFields)
|
||||
parserForLanguage Nothing = LineByLineParser
|
||||
parserForLanguage (Just language) = case language of
|
||||
C -> TreeSitterParser tree_sitter_c
|
||||
@ -80,6 +80,6 @@ markdownParser = AssignmentParser MarkdownParser (\ (node@Node{..} :< _) -> node
|
||||
|
||||
|
||||
-- | A fallback parser that treats a file simply as rows of strings.
|
||||
lineByLineParser :: Source -> SyntaxTerm Text DefaultFields
|
||||
lineByLineParser :: Source -> SyntaxTerm DefaultFields
|
||||
lineByLineParser source = cofree $ (totalRange source :. Program :. totalSpan source :. Nil) :< Indexed (zipWith toLine [1..] (sourceLineRanges source))
|
||||
where toLine line range = cofree $ (range :. Program :. Span (Pos line 1) (Pos line (end range)) :. Nil) :< Leaf (toText (slice range source))
|
||||
|
||||
@ -42,7 +42,7 @@ data DiffRenderer output where
|
||||
-- | Render to a 'ByteString' formatted as nested s-expressions with patches indicated.
|
||||
SExpressionDiffRenderer :: DiffRenderer ByteString
|
||||
-- | “Render” by returning the computed 'SyntaxDiff'. This renderer is not surfaced in the command-line interface, and is intended strictly for tests. Further, as it cannot render à la carte terms, it should be regarded as a (very) short-term hack until such time as we have a better idea for TOCSpec.hs.
|
||||
IdentityDiffRenderer :: DiffRenderer (Maybe (SyntaxDiff Text (Maybe Declaration ': DefaultFields)))
|
||||
IdentityDiffRenderer :: DiffRenderer (Maybe (SyntaxDiff (Maybe Declaration ': DefaultFields)))
|
||||
|
||||
deriving instance Eq (DiffRenderer output)
|
||||
deriving instance Show (DiffRenderer output)
|
||||
@ -56,7 +56,7 @@ data TermRenderer output where
|
||||
-- | Render to a 'ByteString' formatted as nested s-expressions.
|
||||
SExpressionTermRenderer :: TermRenderer ByteString
|
||||
-- | “Render” by returning the computed 'SyntaxTerm'. This renderer is not surfaced in the command-line interface, and is intended strictly for tests. Further, as it cannot render à la carte terms, it should be regarded as a (very) short-term hack until such time as we have a better idea for SemanticSpec.hs.
|
||||
IdentityTermRenderer :: TermRenderer (Maybe (SyntaxTerm Text DefaultFields))
|
||||
IdentityTermRenderer :: TermRenderer (Maybe (SyntaxTerm DefaultFields))
|
||||
|
||||
deriving instance Eq (TermRenderer output)
|
||||
deriving instance Show (TermRenderer output)
|
||||
@ -70,7 +70,7 @@ data SomeRenderer f where
|
||||
|
||||
deriving instance Show (SomeRenderer f)
|
||||
|
||||
identifierAlgebra :: RAlgebra (CofreeF (Syntax Text) a) (Cofree (Syntax Text) a) (Maybe Identifier)
|
||||
identifierAlgebra :: RAlgebra (CofreeF Syntax a) (Cofree Syntax a) (Maybe Identifier)
|
||||
identifierAlgebra (_ :< syntax) = case syntax of
|
||||
S.Assignment f _ -> identifier f
|
||||
S.Class f _ _ -> identifier f
|
||||
|
||||
@ -100,7 +100,7 @@ instance ToJSON a => ToJSONFields (Patch a) where
|
||||
instance ToJSON a => ToJSONFields [a] where
|
||||
toJSONFields list = [ "children" .= list ]
|
||||
|
||||
instance ToJSON recur => ToJSONFields (Syntax leaf recur) where
|
||||
instance ToJSON recur => ToJSONFields (Syntax recur) where
|
||||
toJSONFields syntax = [ "children" .= toList syntax ]
|
||||
|
||||
instance (Foldable f, ToJSON a, ToJSONFields (Union fs a)) => ToJSONFields (Union (f ': fs) a) where
|
||||
|
||||
@ -93,7 +93,7 @@ declaration (annotation :< _) = annotation <$ (getField annotation :: Maybe Decl
|
||||
|
||||
|
||||
-- | Compute 'Declaration's for methods and functions in 'Syntax'.
|
||||
syntaxDeclarationAlgebra :: HasField fields Range => Blob -> RAlgebra (SyntaxTermF Text fields) (SyntaxTerm Text fields) (Maybe Declaration)
|
||||
syntaxDeclarationAlgebra :: HasField fields Range => Blob -> RAlgebra (SyntaxTermF fields) (SyntaxTerm fields) (Maybe Declaration)
|
||||
syntaxDeclarationAlgebra Blob{..} r = case tailF r of
|
||||
S.Function (identifier, _) _ _ -> Just $ FunctionDeclaration (getSource identifier)
|
||||
S.Method _ (identifier, _) Nothing _ _ -> Just $ MethodDeclaration (getSource identifier)
|
||||
|
||||
@ -3,7 +3,6 @@ module SplitDiff where
|
||||
import Data.Record
|
||||
import Info
|
||||
import Prologue
|
||||
import Syntax
|
||||
import Term (Term, TermF)
|
||||
|
||||
-- | A patch to only one side of a diff.
|
||||
@ -24,4 +23,3 @@ getRange diff = byteRange $ case runFree diff of
|
||||
|
||||
-- | A diff with only one side’s annotations.
|
||||
type SplitDiff f annotation = Free (TermF f annotation) (SplitPatch (Term f annotation))
|
||||
type SplitSyntaxDiff leaf fields = SplitDiff (Syntax leaf) (Record fields)
|
||||
|
||||
@ -7,16 +7,16 @@ import Data.Functor.Classes
|
||||
import Data.Functor.Classes.Eq.Generic
|
||||
import Data.Functor.Listable
|
||||
import Data.Mergeable
|
||||
import Data.Text (pack)
|
||||
import GHC.Generics
|
||||
import Prologue
|
||||
|
||||
-- | A node in an abstract syntax tree.
|
||||
--
|
||||
-- 'a' is the type of leaves in the syntax tree, typically 'Text', but possibly some datatype representing different leaves more precisely.
|
||||
-- 'f' is the type representing another level of the tree, e.g. the children of branches. Often 'Cofree', 'Free' or similar.
|
||||
data Syntax a f
|
||||
data Syntax f
|
||||
-- | A terminal syntax node, e.g. an identifier, or atomic literal.
|
||||
= Leaf a
|
||||
= Leaf Text
|
||||
-- | An ordered branch of child nodes, expected to be variadic in the grammar, e.g. a list of statements or uncurried function parameters.
|
||||
| Indexed [f]
|
||||
-- | An ordered branch of child nodes, expected to be of fixed length in the grammar, e.g. a binary operator & its operands.
|
||||
@ -24,52 +24,52 @@ data Syntax a f
|
||||
-- | A function call has an identifier where f is a (Leaf a) and a list of arguments.
|
||||
| FunctionCall f [f] [f]
|
||||
-- | A ternary has a condition, a true case and a false case
|
||||
| Ternary { ternaryCondition :: f, ternaryCases :: [f] }
|
||||
| Ternary f [f]
|
||||
-- | An anonymous function has a list of expressions and params.
|
||||
| AnonymousFunction { params :: [f], expressions :: [f] }
|
||||
| AnonymousFunction [f] [f]
|
||||
-- | A function has an identifier, possible type arguments, params, a possible type, and list of expressions.
|
||||
| Function { id :: f, params :: [f], expressions :: [f] }
|
||||
| Function f [f] [f]
|
||||
-- | An assignment has an identifier where f can be a member access, and the value is another syntax element (function call, leaf, etc.)
|
||||
| Assignment { assignmentId :: f, value :: f }
|
||||
| Assignment f f
|
||||
-- | An operator assignment represents expressions with operators like math (e.g x += 1) or conditional (e.g. x ||= 1) assignment.
|
||||
| OperatorAssignment f f
|
||||
-- | A member access contains a syntax, and another syntax that identifies a property or value in the first syntax.
|
||||
-- | e.g. in Javascript x.y represents a member access syntax.
|
||||
| MemberAccess { memberId :: f, property :: f }
|
||||
| MemberAccess f f
|
||||
-- | A method call consisting of its target, the method name, and the parameters passed to the method.
|
||||
-- | e.g. in Javascript console.log('hello') represents a method call.
|
||||
| MethodCall { targetId :: f, methodId :: f, typeArgs :: [f], methodParams :: [f] }
|
||||
| MethodCall f f [f] [f]
|
||||
-- | An operator can be applied to a list of syntaxes.
|
||||
| Operator [f]
|
||||
-- | A variable declaration. e.g. var foo;
|
||||
| VarDecl [f]
|
||||
-- | A variable assignment in a variable declaration. var foo = bar;
|
||||
| VarAssignment { varId :: [f], varValue :: f }
|
||||
| VarAssignment [f] f
|
||||
-- | A subscript access contains a syntax, and another syntax that indefies a property or value in the first syntax.
|
||||
-- | e.g. in Javascript x["y"] represents a subscript access syntax.
|
||||
| SubscriptAccess { subscriptId :: f, subscriptElement :: f }
|
||||
| Switch { switchExpr :: [f], cases :: [f] }
|
||||
| Case { caseExpr :: f, caseStatements :: [f] }
|
||||
| SubscriptAccess f f
|
||||
| Switch [f] [f]
|
||||
| Case f [f]
|
||||
-- | A default case in a switch statement.
|
||||
| DefaultCase [f]
|
||||
| Select { cases :: [f] }
|
||||
| Object { objectTy :: Maybe f, keyValues :: [f] }
|
||||
| Select [f]
|
||||
| Object (Maybe f) [f]
|
||||
-- | A pair in an Object. e.g. foo: bar or foo => bar
|
||||
| Pair f f
|
||||
-- | A comment.
|
||||
| Comment a
|
||||
| Comment Text
|
||||
-- | A term preceded or followed by any number of comments.
|
||||
| Commented [f] (Maybe f)
|
||||
| ParseError [f]
|
||||
-- | A for statement has a list of expressions to setup the iteration and then a list of expressions in the body.
|
||||
| For [f] [f]
|
||||
| DoWhile { doWhileBody :: f, doWhileExpr :: f }
|
||||
| While { whileExpr :: f, whileBody :: [f] }
|
||||
| DoWhile f f
|
||||
| While f [f]
|
||||
| Return [f]
|
||||
| Throw f
|
||||
| Constructor f
|
||||
-- | TODO: Is it a problem that in Ruby, this pattern can work for method def too?
|
||||
| Try { tryBegin :: [f], catchRescue :: [f], beginElse :: Maybe f, finallyEnsure :: Maybe f }
|
||||
| Try [f] [f] (Maybe f) (Maybe f)
|
||||
-- | An array literal with list of children.
|
||||
| Array (Maybe f) [f]
|
||||
-- | A class with an identifier, superclass, and a list of definitions.
|
||||
@ -79,10 +79,10 @@ data Syntax a f
|
||||
-- | An if statement with an expression and maybe more expression clauses.
|
||||
| If f [f]
|
||||
-- | A module with an identifier, and a list of syntaxes.
|
||||
| Module { moduleId:: f, moduleBody :: [f] }
|
||||
| Module f [f]
|
||||
-- | An interface with an identifier, a list of clauses, and a list of declarations..
|
||||
| Interface f [f] [f]
|
||||
| Namespace { namespaceId:: f, namespaceBody :: [f] }
|
||||
| Namespace f [f]
|
||||
| Import f [f]
|
||||
| Export (Maybe f) [f]
|
||||
| Yield [f]
|
||||
@ -113,16 +113,16 @@ data Syntax a f
|
||||
deriving (Eq, Foldable, Functor, Generic, Generic1, Mergeable, Ord, Show, Traversable, ToJSON, NFData)
|
||||
|
||||
|
||||
extractLeafValue :: Syntax leaf b -> Maybe leaf
|
||||
extractLeafValue :: Syntax a -> Maybe Text
|
||||
extractLeafValue syntax = case syntax of
|
||||
Leaf a -> Just a
|
||||
_ -> Nothing
|
||||
|
||||
-- Instances
|
||||
|
||||
instance Listable2 Syntax where
|
||||
liftTiers2 leaf recur
|
||||
= liftCons1 leaf Leaf
|
||||
instance Listable1 Syntax where
|
||||
liftTiers recur
|
||||
= liftCons1 (pack `mapT` tiers) Leaf
|
||||
\/ liftCons1 (liftTiers recur) Indexed
|
||||
\/ liftCons1 (liftTiers recur) Fixed
|
||||
\/ liftCons3 recur (liftTiers recur) (liftTiers recur) FunctionCall
|
||||
@ -142,7 +142,7 @@ instance Listable2 Syntax where
|
||||
\/ liftCons1 (liftTiers recur) Select
|
||||
\/ liftCons2 (liftTiers recur) (liftTiers recur) Syntax.Object
|
||||
\/ liftCons2 recur recur Pair
|
||||
\/ liftCons1 leaf Comment
|
||||
\/ liftCons1 (pack `mapT` tiers) Comment
|
||||
\/ liftCons2 (liftTiers recur) (liftTiers recur) Commented
|
||||
\/ liftCons1 (liftTiers recur) Syntax.ParseError
|
||||
\/ liftCons2 (liftTiers recur) (liftTiers recur) For
|
||||
@ -177,13 +177,10 @@ instance Listable2 Syntax where
|
||||
\/ liftCons2 recur recur Send
|
||||
\/ liftCons1 (liftTiers recur) DefaultCase
|
||||
|
||||
instance Listable leaf => Listable1 (Syntax leaf) where
|
||||
liftTiers = liftTiers2 tiers
|
||||
|
||||
instance (Listable leaf, Listable recur) => Listable (Syntax leaf recur) where
|
||||
instance Listable recur => Listable (Syntax recur) where
|
||||
tiers = tiers1
|
||||
|
||||
instance Eq leaf => Eq1 (Syntax leaf) where
|
||||
instance Eq1 Syntax where
|
||||
liftEq = genericLiftEq
|
||||
|
||||
instance Eq leaf => GAlign (Syntax leaf)
|
||||
instance GAlign Syntax
|
||||
|
||||
@ -14,8 +14,8 @@ type Term f = Cofree f
|
||||
type TermF = CofreeF
|
||||
|
||||
-- | A Term with a Syntax leaf and a record of fields.
|
||||
type SyntaxTerm leaf fields = Term (Syntax leaf) (Record fields)
|
||||
type SyntaxTermF leaf fields = TermF (Syntax leaf) (Record fields)
|
||||
type SyntaxTerm fields = Term Syntax (Record fields)
|
||||
type SyntaxTermF fields = TermF Syntax (Record fields)
|
||||
|
||||
instance (NFData (f (Cofree f a)), NFData a, Functor f) => NFData (Cofree f a) where
|
||||
rnf = rnf . runCofree
|
||||
|
||||
@ -34,7 +34,7 @@ import qualified Text.Parser.TreeSitter.TypeScript as TS
|
||||
import Info
|
||||
|
||||
-- | Returns a TreeSitter parser for the given language and TreeSitter grammar.
|
||||
treeSitterParser :: Ptr TS.Language -> Blob -> IO (SyntaxTerm Text DefaultFields)
|
||||
treeSitterParser :: Ptr TS.Language -> Blob -> IO (SyntaxTerm DefaultFields)
|
||||
treeSitterParser language blob = bracket ts_document_new ts_document_free $ \ document -> do
|
||||
ts_document_set_language document language
|
||||
unsafeUseAsCStringLen (sourceBytes (blobSource blob)) $ \ (sourceBytes, len) -> do
|
||||
@ -70,13 +70,13 @@ anaM g = a where a = pure . embed <=< traverse a <=< g
|
||||
|
||||
|
||||
-- | Return a parser for a tree sitter language & document.
|
||||
documentToTerm :: Ptr TS.Language -> Ptr Document -> Blob -> IO (SyntaxTerm Text DefaultFields)
|
||||
documentToTerm :: Ptr TS.Language -> Ptr Document -> Blob -> IO (SyntaxTerm DefaultFields)
|
||||
documentToTerm language document Blob{..} = do
|
||||
root <- alloca (\ rootPtr -> do
|
||||
ts_document_root_node_p document rootPtr
|
||||
peek rootPtr)
|
||||
toTerm root
|
||||
where toTerm :: Node -> IO (SyntaxTerm Text DefaultFields)
|
||||
where toTerm :: Node -> IO (SyntaxTerm DefaultFields)
|
||||
toTerm node = do
|
||||
name <- peekCString (nodeType node)
|
||||
|
||||
@ -95,7 +95,7 @@ documentToTerm language document Blob{..} = do
|
||||
copyNamed = ts_node_copy_named_child_nodes document
|
||||
copyAll = ts_node_copy_child_nodes document
|
||||
|
||||
isNonEmpty :: HasField fields Category => SyntaxTerm Text fields -> Bool
|
||||
isNonEmpty :: HasField fields Category => SyntaxTerm fields -> Bool
|
||||
isNonEmpty = (/= Empty) . category . extract
|
||||
|
||||
nodeRange :: Node -> Range
|
||||
@ -105,12 +105,12 @@ nodeSpan :: Node -> Span
|
||||
nodeSpan Node{..} = nodeStartPoint `seq` nodeEndPoint `seq` Span (pointPos nodeStartPoint) (pointPos nodeEndPoint)
|
||||
where pointPos TSPoint{..} = pointRow `seq` pointColumn `seq` Pos (1 + fromIntegral pointRow) (1 + fromIntegral pointColumn)
|
||||
|
||||
assignTerm :: Ptr TS.Language -> Source -> Record DefaultFields -> [ SyntaxTerm Text DefaultFields ] -> IO [ SyntaxTerm Text DefaultFields ] -> IO (SyntaxTerm Text DefaultFields)
|
||||
assignTerm :: Ptr TS.Language -> Source -> Record DefaultFields -> [ SyntaxTerm DefaultFields ] -> IO [ SyntaxTerm DefaultFields ] -> IO (SyntaxTerm DefaultFields)
|
||||
assignTerm language source annotation children allChildren =
|
||||
cofree . (annotation :<) <$> case assignTermByLanguage source (category annotation) children of
|
||||
Just a -> pure a
|
||||
_ -> defaultTermAssignment source (category annotation) children allChildren
|
||||
where assignTermByLanguage :: Source -> Category -> [ SyntaxTerm Text DefaultFields ] -> Maybe (S.Syntax Text (SyntaxTerm Text DefaultFields))
|
||||
where assignTermByLanguage :: Source -> Category -> [ SyntaxTerm DefaultFields ] -> Maybe (S.Syntax (SyntaxTerm DefaultFields))
|
||||
assignTermByLanguage = case languageForTSLanguage language of
|
||||
Just C -> C.termAssignment
|
||||
Just Language.Go -> Go.termAssignment
|
||||
@ -118,7 +118,7 @@ assignTerm language source annotation children allChildren =
|
||||
Just TypeScript -> TS.termAssignment
|
||||
_ -> \ _ _ _ -> Nothing
|
||||
|
||||
defaultTermAssignment :: Source -> Category -> [ SyntaxTerm Text DefaultFields ] -> IO [ SyntaxTerm Text DefaultFields ] -> IO (S.Syntax Text (SyntaxTerm Text DefaultFields))
|
||||
defaultTermAssignment :: Source -> Category -> [ SyntaxTerm DefaultFields ] -> IO [ SyntaxTerm DefaultFields ] -> IO (S.Syntax (SyntaxTerm DefaultFields))
|
||||
defaultTermAssignment source category children allChildren
|
||||
| category `elem` operatorCategories = S.Operator <$> allChildren
|
||||
| otherwise = pure $! case (category, children) of
|
||||
|
||||
@ -31,7 +31,7 @@ spec :: Spec
|
||||
spec = parallel $ do
|
||||
describe "alignBranch" $ do
|
||||
it "produces symmetrical context" $
|
||||
alignBranch getRange ([] :: [Join These (SplitDiff (Syntax Text) (Record '[Range]))]) (both [Range 0 2, Range 2 4] [Range 0 2, Range 2 4]) `shouldBe`
|
||||
alignBranch getRange ([] :: [Join These (SplitDiff Syntax (Record '[Range]))]) (both [Range 0 2, Range 2 4] [Range 0 2, Range 2 4]) `shouldBe`
|
||||
[ Join (These (Range 0 2, [])
|
||||
(Range 0 2, []))
|
||||
, Join (These (Range 2 4, [])
|
||||
@ -39,7 +39,7 @@ spec = parallel $ do
|
||||
]
|
||||
|
||||
it "produces asymmetrical context" $
|
||||
alignBranch getRange ([] :: [Join These (SplitDiff (Syntax Text) (Record '[Range]))]) (both [Range 0 2, Range 2 4] [Range 0 1]) `shouldBe`
|
||||
alignBranch getRange ([] :: [Join These (SplitDiff Syntax (Record '[Range]))]) (both [Range 0 2, Range 2 4] [Range 0 1]) `shouldBe`
|
||||
[ Join (These (Range 0 2, [])
|
||||
(Range 0 1, []))
|
||||
, Join (This (Range 2 4, []))
|
||||
@ -256,7 +256,7 @@ instance Listable BranchElement where
|
||||
counts :: [Join These (Int, a)] -> Both Int
|
||||
counts numbered = fromMaybe 0 . getLast . mconcat . fmap Last <$> Join (unalign (runJoin . fmap Prologue.fst <$> numbered))
|
||||
|
||||
align :: Both Source.Source -> ConstructibleFree (Syntax Text) (Patch (Term (Syntax Text) (Record '[Range]))) (Both (Record '[Range])) -> PrettyDiff (SplitDiff [] (Record '[Range]))
|
||||
align :: Both Source.Source -> ConstructibleFree Syntax (Patch (Term Syntax (Record '[Range]))) (Both (Record '[Range])) -> PrettyDiff (SplitDiff [] (Record '[Range]))
|
||||
align sources = PrettyDiff sources . fmap (fmap (getRange &&& identity)) . alignDiff sources . deconstruct
|
||||
|
||||
info :: Int -> Int -> Record '[Range]
|
||||
@ -281,14 +281,14 @@ newtype ConstructibleFree f patch annotation = ConstructibleFree { deconstruct :
|
||||
|
||||
|
||||
class PatchConstructible p where
|
||||
insert :: Term (Syntax Text) (Record '[Range]) -> p
|
||||
delete :: Term (Syntax Text) (Record '[Range]) -> p
|
||||
insert :: Term Syntax (Record '[Range]) -> p
|
||||
delete :: Term Syntax (Record '[Range]) -> p
|
||||
|
||||
instance PatchConstructible (Patch (Term (Syntax Text) (Record '[Range]))) where
|
||||
instance PatchConstructible (Patch (Term Syntax (Record '[Range]))) where
|
||||
insert = Insert
|
||||
delete = Delete
|
||||
|
||||
instance PatchConstructible (SplitPatch (Term (Syntax Text) (Record '[Range]))) where
|
||||
instance PatchConstructible (SplitPatch (Term Syntax (Record '[Range]))) where
|
||||
insert = SplitInsert
|
||||
delete = SplitDelete
|
||||
|
||||
@ -304,7 +304,7 @@ class SyntaxConstructible s where
|
||||
leaf :: annotation -> Text -> s annotation
|
||||
branch :: annotation -> [s annotation] -> s annotation
|
||||
|
||||
instance SyntaxConstructible (ConstructibleFree (Syntax Text) patch) where
|
||||
instance SyntaxConstructible (ConstructibleFree Syntax patch) where
|
||||
leaf info = ConstructibleFree . free . Free . (info :<) . Leaf
|
||||
branch info = ConstructibleFree . free . Free . (info :<) . Indexed . fmap deconstruct
|
||||
|
||||
@ -312,7 +312,7 @@ instance SyntaxConstructible (ConstructibleFree [] patch) where
|
||||
leaf info = ConstructibleFree . free . Free . (info :<) . const []
|
||||
branch info = ConstructibleFree . free . Free . (info :<) . fmap deconstruct
|
||||
|
||||
instance SyntaxConstructible (Cofree (Syntax Text)) where
|
||||
instance SyntaxConstructible (Cofree Syntax) where
|
||||
info `leaf` value = cofree $ info :< Leaf value
|
||||
info `branch` children = cofree $ info :< Indexed children
|
||||
|
||||
|
||||
@ -24,8 +24,8 @@ spec = parallel $ do
|
||||
withAlternativeInstances sequenceAltLaws (Identity `mapT` tiers :: [Tier (Identity Char)])
|
||||
withAlternativeInstances mergeLaws (Identity `mapT` tiers :: [Tier (Identity Char)])
|
||||
describe "Syntax" $ do
|
||||
withAlternativeInstances sequenceAltLaws (tiers :: [Tier (Syntax Char Char)])
|
||||
withAlternativeInstances mergeLaws (tiers :: [Tier (Syntax Char Char)])
|
||||
withAlternativeInstances sequenceAltLaws (tiers :: [Tier (Syntax Char)])
|
||||
withAlternativeInstances mergeLaws (tiers :: [Tier (Syntax Char)])
|
||||
|
||||
prop "subsumes catMaybes/Just" $
|
||||
\ a -> sequenceAlt a `shouldBe` pure (catMaybes (a :: [Maybe Char]))
|
||||
|
||||
@ -7,7 +7,6 @@ import Data.Bifunctor
|
||||
import Data.Functor.Listable
|
||||
import RWS
|
||||
import Data.Record
|
||||
import Data.String
|
||||
import Data.These
|
||||
import Diff
|
||||
import Info
|
||||
@ -23,30 +22,30 @@ spec = parallel $ do
|
||||
let positively = succ . abs
|
||||
describe "pqGramDecorator" $ do
|
||||
prop "produces grams with stems of the specified length" $
|
||||
\ (term, p, q) -> pqGramDecorator (rhead . headF) (positively p) (positively q) (unListableF term :: SyntaxTerm String '[Category]) `shouldSatisfy` all ((== positively p) . length . stem . rhead)
|
||||
\ (term, p, q) -> pqGramDecorator (rhead . headF) (positively p) (positively q) (unListableF term :: SyntaxTerm '[Category]) `shouldSatisfy` all ((== positively p) . length . stem . rhead)
|
||||
|
||||
prop "produces grams with bases of the specified width" $
|
||||
\ (term, p, q) -> pqGramDecorator (rhead . headF) (positively p) (positively q) (unListableF term :: SyntaxTerm String '[Category]) `shouldSatisfy` all ((== positively q) . length . base . rhead)
|
||||
\ (term, p, q) -> pqGramDecorator (rhead . headF) (positively p) (positively q) (unListableF term :: SyntaxTerm '[Category]) `shouldSatisfy` all ((== positively q) . length . base . rhead)
|
||||
|
||||
describe "featureVectorDecorator" $ do
|
||||
prop "produces a vector of the specified dimension" $
|
||||
\ (term, p, q, d) -> featureVectorDecorator (rhead . headF) (positively p) (positively q) (positively d) (unListableF term :: SyntaxTerm String '[Category]) `shouldSatisfy` all ((== (0, abs d)) . bounds . rhead)
|
||||
\ (term, p, q, d) -> featureVectorDecorator (rhead . headF) (positively p) (positively q) (positively d) (unListableF term :: SyntaxTerm '[Category]) `shouldSatisfy` all ((== (0, abs d)) . bounds . rhead)
|
||||
|
||||
describe "rws" $ do
|
||||
prop "produces correct diffs" $
|
||||
\ (as, bs) -> let tas = decorate <$> (unListableF <$> as :: [SyntaxTerm String '[Category]])
|
||||
tbs = decorate <$> (unListableF <$> bs :: [SyntaxTerm String '[Category]])
|
||||
\ (as, bs) -> let tas = decorate <$> (unListableF <$> as :: [SyntaxTerm '[Category]])
|
||||
tbs = decorate <$> (unListableF <$> bs :: [SyntaxTerm '[Category]])
|
||||
root = cofree . ((Program :. Nil) :<) . Indexed
|
||||
diff = wrap (pure (Program :. Nil) :< Indexed (stripDiff . diffThese <$> rws editDistance canCompare tas tbs)) in
|
||||
(beforeTerm diff, afterTerm diff) `shouldBe` (Just (root (stripTerm <$> tas)), Just (root (stripTerm <$> tbs)))
|
||||
|
||||
it "produces unbiased insertions within branches" $
|
||||
let (a, b) = (decorate (cofree ((StringLiteral :. Nil) :< Indexed [ cofree ((StringLiteral :. Nil) :< Leaf ("a" :: String)) ])), decorate (cofree ((StringLiteral :. Nil) :< Indexed [ cofree ((StringLiteral :. Nil) :< Leaf "b") ]))) in
|
||||
let (a, b) = (decorate (cofree ((StringLiteral :. Nil) :< Indexed [ cofree ((StringLiteral :. Nil) :< Leaf "a") ])), decorate (cofree ((StringLiteral :. Nil) :< Indexed [ cofree ((StringLiteral :. Nil) :< Leaf "b") ]))) in
|
||||
fmap (bimap stripTerm stripTerm) (rws editDistance canCompare [ b ] [ a, b ]) `shouldBe` fmap (bimap stripTerm stripTerm) [ That a, These b b ]
|
||||
|
||||
where canCompare a b = headF a == headF b
|
||||
|
||||
decorate :: SyntaxTerm leaf '[Category] -> SyntaxTerm leaf '[FeatureVector, Category]
|
||||
decorate :: SyntaxTerm '[Category] -> SyntaxTerm '[FeatureVector, Category]
|
||||
decorate = defaultFeatureVectorDecorator (category . headF)
|
||||
|
||||
diffThese = these deleting inserting replacing
|
||||
|
||||
@ -5,7 +5,6 @@ import Category
|
||||
import Data.Functor.Both
|
||||
import Data.Functor.Listable
|
||||
import RWS
|
||||
import Data.String
|
||||
import Diff
|
||||
import Info
|
||||
import Interpreter
|
||||
@ -19,19 +18,19 @@ spec :: Spec
|
||||
spec = parallel $ do
|
||||
let decorate = defaultFeatureVectorDecorator (category . headF)
|
||||
prop "equality is reflexive" $
|
||||
\ a -> let diff = unListableDiff a :: SyntaxDiff String '[Category] in
|
||||
\ a -> let diff = unListableDiff a :: SyntaxDiff '[Category] in
|
||||
diff `shouldBe` diff
|
||||
|
||||
prop "equal terms produce identity diffs" $
|
||||
\ a -> let term = decorate (unListableF a :: SyntaxTerm String '[Category]) in
|
||||
\ a -> let term = decorate (unListableF a :: SyntaxTerm '[Category]) in
|
||||
diffCost (diffTerms (pure term)) `shouldBe` 0
|
||||
|
||||
describe "beforeTerm" $ do
|
||||
prop "recovers the before term" $
|
||||
\ a b -> let diff = diffTerms (unListableF <$> both a b :: Both (SyntaxTerm String '[Category])) in
|
||||
\ a b -> let diff = diffTerms (unListableF <$> both a b :: Both (SyntaxTerm '[Category])) in
|
||||
beforeTerm diff `shouldBe` Just (unListableF a)
|
||||
|
||||
describe "afterTerm" $ do
|
||||
prop "recovers the after term" $
|
||||
\ a b -> let diff = diffTerms (unListableF <$> both a b :: Both (SyntaxTerm String '[Category])) in
|
||||
\ a b -> let diff = diffTerms (unListableF <$> both a b :: Both (SyntaxTerm '[Category])) in
|
||||
afterTerm diff `shouldBe` Just (unListableF b)
|
||||
|
||||
@ -6,7 +6,6 @@ import Data.Functor.Both
|
||||
import Data.Functor.Foldable hiding (Nil)
|
||||
import Data.Functor.Listable
|
||||
import Data.Record
|
||||
import Data.String
|
||||
import Diff
|
||||
import Interpreter
|
||||
import Patch
|
||||
@ -21,20 +20,20 @@ spec :: Spec
|
||||
spec = parallel $ do
|
||||
describe "interpret" $ do
|
||||
it "returns a replacement when comparing two unicode equivalent terms" $
|
||||
let termA = cofree $ (StringLiteral :. Nil) :< Leaf ("t\776" :: String)
|
||||
let termA = cofree $ (StringLiteral :. Nil) :< Leaf "t\776"
|
||||
termB = cofree $ (StringLiteral :. Nil) :< Leaf "\7831" in
|
||||
diffTerms (both termA termB) `shouldBe` replacing termA termB
|
||||
|
||||
prop "produces correct diffs" $
|
||||
\ a b -> let diff = diffTerms (unListableF <$> both a b :: Both (SyntaxTerm String '[Category])) in
|
||||
\ a b -> let diff = diffTerms (unListableF <$> both a b :: Both (SyntaxTerm '[Category])) in
|
||||
(beforeTerm diff, afterTerm diff) `shouldBe` (Just (unListableF a), Just (unListableF b))
|
||||
|
||||
prop "constructs zero-cost diffs of equal terms" $
|
||||
\ a -> let term = (unListableF a :: SyntaxTerm String '[Category])
|
||||
\ a -> let term = (unListableF a :: SyntaxTerm '[Category])
|
||||
diff = diffTerms (pure term) in
|
||||
diffCost diff `shouldBe` 0
|
||||
|
||||
it "produces unbiased insertions within branches" $
|
||||
let term s = cofree ((StringLiteral :. Nil) :< Indexed [ cofree ((StringLiteral :. Nil) :< Leaf s) ]) :: SyntaxTerm String '[Category]
|
||||
let term s = cofree ((StringLiteral :. Nil) :< Indexed [ cofree ((StringLiteral :. Nil) :< Leaf s) ]) :: SyntaxTerm '[Category]
|
||||
root = cofree . ((Program :. Nil) :<) . Indexed in
|
||||
diffTerms (both (root [ term "b" ]) (root [ term "a", term "b" ])) `shouldBe` wrap (pure (Program :. Nil) :< Indexed [ inserting (term "a"), cata wrap (fmap pure (term "b")) ])
|
||||
|
||||
@ -34,21 +34,21 @@ spec :: Spec
|
||||
spec = parallel $ do
|
||||
describe "tableOfContentsBy" $ do
|
||||
prop "drops all nodes with the constant Nothing function" $
|
||||
\ diff -> tableOfContentsBy (const Nothing :: a -> Maybe ()) (unListableDiff diff :: Diff (Syntax ()) ()) `shouldBe` []
|
||||
\ diff -> tableOfContentsBy (const Nothing :: a -> Maybe ()) (unListableDiff diff :: Diff Syntax ()) `shouldBe` []
|
||||
|
||||
let diffSize = max 1 . sum . fmap (const 1)
|
||||
let lastValue a = fromMaybe (extract a) (getLast (foldMap (Last . Just) a))
|
||||
prop "includes all nodes with a constant Just function" $
|
||||
\ diff -> let diff' = (unListableDiff diff :: Diff (Syntax ()) ()) in entryPayload <$> tableOfContentsBy (const (Just ())) diff' `shouldBe` replicate (diffSize diff') ()
|
||||
\ diff -> let diff' = (unListableDiff diff :: Diff Syntax ()) in entryPayload <$> tableOfContentsBy (const (Just ())) diff' `shouldBe` replicate (diffSize diff') ()
|
||||
|
||||
prop "produces an unchanged entry for identity diffs" $
|
||||
\ term -> let term' = (unListableF term :: Term (Syntax ()) (Record '[Category])) in tableOfContentsBy (Just . headF) (diffTerms (pure term')) `shouldBe` [Unchanged (lastValue term')]
|
||||
\ term -> let term' = (unListableF term :: Term Syntax (Record '[Category])) in tableOfContentsBy (Just . headF) (diffTerms (pure term')) `shouldBe` [Unchanged (lastValue term')]
|
||||
|
||||
prop "produces inserted/deleted/replaced entries for relevant nodes within patches" $
|
||||
\ patch -> let patch' = (unListableF <$> patch :: Patch (Term (Syntax ()) Int)) in tableOfContentsBy (Just . headF) (pure patch') `shouldBe` these (pure . Deleted) (pure . Inserted) ((<>) `on` pure . Replaced) (unPatch (lastValue <$> patch'))
|
||||
\ patch -> let patch' = (unListableF <$> patch :: Patch (Term Syntax Int)) in tableOfContentsBy (Just . headF) (pure patch') `shouldBe` these (pure . Deleted) (pure . Inserted) ((<>) `on` pure . Replaced) (unPatch (lastValue <$> patch'))
|
||||
|
||||
prop "produces changed entries for relevant nodes containing irrelevant patches" $
|
||||
\ diff -> let diff' = fmap (1 <$) <$> mapAnnotations (const (0 :: Int)) (wrap (pure 0 :< Indexed [unListableDiff diff :: Diff (Syntax ()) Int])) in
|
||||
\ diff -> let diff' = fmap (1 <$) <$> mapAnnotations (const (0 :: Int)) (wrap (pure 0 :< Indexed [unListableDiff diff :: Diff Syntax Int])) in
|
||||
tableOfContentsBy (\ (n :< _) -> if n == 0 then Just n else Nothing) diff' `shouldBe`
|
||||
if Prologue.null diff' then [Unchanged 0]
|
||||
else replicate (length diff') (Changed 0)
|
||||
@ -155,8 +155,8 @@ spec = parallel $ do
|
||||
toS output `shouldBe` ("{\"changes\":{\"test/fixtures/toc/markdown/headings.A.md -> test/fixtures/toc/markdown/headings.B.md\":[{\"span\":{\"start\":[5,1],\"end\":[5,7]},\"category\":\"Heading 2\",\"term\":\"## Two\",\"changeType\":\"added\"},{\"span\":{\"start\":[9,1],\"end\":[10,4]},\"category\":\"Heading 1\",\"term\":\"Final\",\"changeType\":\"added\"}]},\"errors\":{}}\n" :: ByteString)
|
||||
|
||||
|
||||
type Diff' = SyntaxDiff Text (Maybe Declaration ': DefaultFields)
|
||||
type Term' = SyntaxTerm Text (Maybe Declaration ': DefaultFields)
|
||||
type Diff' = SyntaxDiff (Maybe Declaration ': DefaultFields)
|
||||
type Term' = SyntaxTerm (Maybe Declaration ': DefaultFields)
|
||||
|
||||
numTocSummaries :: Diff' -> Int
|
||||
numTocSummaries diff = length $ filter isValidSummary (diffTOC diff)
|
||||
@ -200,7 +200,7 @@ functionInfo :: Record DefaultFields
|
||||
functionInfo = Range 0 0 :. C.Function :. sourceSpanBetween (0,0) (0,0) :. Nil
|
||||
|
||||
-- Filter tiers for terms that we consider "meaniningful" in TOC summaries.
|
||||
isMeaningfulTerm :: ListableF (Term (Syntax leaf)) a -> Bool
|
||||
isMeaningfulTerm :: ListableF (Term Syntax) a -> Bool
|
||||
isMeaningfulTerm a = case runCofree (unListableF a) of
|
||||
(_ :< S.Indexed _) -> False
|
||||
(_ :< S.Fixed _) -> False
|
||||
@ -209,7 +209,7 @@ isMeaningfulTerm a = case runCofree (unListableF a) of
|
||||
_ -> True
|
||||
|
||||
-- Filter tiers for terms if the Syntax is a Method or a Function.
|
||||
isMethodOrFunction :: HasField fields Category => ListableF (Term (Syntax leaf)) (Record fields) -> Bool
|
||||
isMethodOrFunction :: HasField fields Category => ListableF (Term Syntax) (Record fields) -> Bool
|
||||
isMethodOrFunction a = case runCofree (unListableF a) of
|
||||
(_ :< S.Method{}) -> True
|
||||
(_ :< S.Function{}) -> True
|
||||
|
||||
@ -3,7 +3,6 @@ module TermSpec where
|
||||
|
||||
import Category
|
||||
import Data.Functor.Listable
|
||||
import Data.String (String)
|
||||
import Prologue
|
||||
import Term
|
||||
import Test.Hspec (Spec, describe, parallel)
|
||||
@ -14,4 +13,4 @@ spec :: Spec
|
||||
spec = parallel $ do
|
||||
describe "Term" $ do
|
||||
prop "equality is reflexive" $
|
||||
\ a -> unListableF a `shouldBe` (unListableF a :: SyntaxTerm String '[Category])
|
||||
\ a -> unListableF a `shouldBe` (unListableF a :: SyntaxTerm '[Category])
|
||||
|
||||
Loading…
Reference in New Issue
Block a user