mirror of
https://github.com/github/semantic.git
synced 2024-12-29 18:06:14 +03:00
Remove the leaf type parameter from Syntax.
This commit is contained in:
parent
8c46ff8afb
commit
0ba3264f32
@ -14,7 +14,7 @@ import Term
|
|||||||
type DiffF f annotation = FreeF (TermF f (Both annotation)) (Patch (Term f annotation))
|
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 Diff f annotation = Free (TermF f (Both annotation)) (Patch (Term f annotation))
|
||||||
|
|
||||||
type SyntaxDiff leaf fields = Diff (Syntax leaf) (Record fields)
|
type SyntaxDiff leaf fields = Diff Syntax (Record fields)
|
||||||
|
|
||||||
diffSum :: (Foldable f, Functor f) => (Patch (Term f annotation) -> Int) -> Diff f annotation -> Int
|
diffSum :: (Foldable f, Functor f) => (Patch (Term f annotation) -> Int) -> Diff f annotation -> Int
|
||||||
diffSum patchCost diff = sum $ fmap patchCost diff
|
diffSum patchCost diff = sum $ fmap patchCost diff
|
||||||
|
@ -25,7 +25,7 @@ structure.
|
|||||||
|
|
||||||
The example below adds a new field to the `Record` fields.
|
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)
|
indexedTermAna childrenLeaves = ana coalgebra (indexedTerm childrenLeaves)
|
||||||
where
|
where
|
||||||
coalgebra term = (NewField :. (extract term)) :< unwrap term
|
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.
|
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)
|
indexedTermCata childrenLeaves = cata algebra (indexedTerm childrenLeaves)
|
||||||
where
|
where
|
||||||
algebra :: Functor f => CofreeF f (Record t) (Cofree f (Record (NewField : t))) -> Cofree f (Record (NewField : t))
|
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
|
the new cofree `Indexed` structure, resulting in a expansion of all possible
|
||||||
string terms.
|
string terms.
|
||||||
-}
|
-}
|
||||||
stringToTermAna :: String -> Term (Syntax String) (Record '[Range, Category])
|
stringToTermAna :: Text -> Term Syntax (Record '[Range, Category])
|
||||||
stringToTermAna = ana coalgebra
|
stringToTermAna = ana coalgebra
|
||||||
where
|
where
|
||||||
coalgebra representation = case representation of
|
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
|
The example below shows how to tear down a recursive Term structure into a list
|
||||||
of String representation.
|
of String representation.
|
||||||
-}
|
-}
|
||||||
termToStringCata :: Term (Syntax String) (Record '[Range, Category]) -> [String]
|
termToStringCata :: Term Syntax (Record '[Range, Category]) -> [Text]
|
||||||
termToStringCata = cata algebra
|
termToStringCata = cata algebra
|
||||||
where
|
where
|
||||||
algebra term = case term of
|
algebra term = case term of
|
||||||
@ -123,7 +123,7 @@ Example Usage:
|
|||||||
stringTermHylo "indexed" => ["indexed", "leaf1", "leaf2", "leaf3"]
|
stringTermHylo "indexed" => ["indexed", "leaf1", "leaf2", "leaf3"]
|
||||||
|
|
||||||
-}
|
-}
|
||||||
stringTermHylo :: String -> [String]
|
stringTermHylo :: Text -> [Text]
|
||||||
stringTermHylo = hylo algebra coalgebra
|
stringTermHylo = hylo algebra coalgebra
|
||||||
where
|
where
|
||||||
algebra term = case term of
|
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
|
termPara = para algebra
|
||||||
where
|
where
|
||||||
algebra term = case term of
|
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
|
leafTermF leaf = (Range 1 10 :. Category.MethodCall :. Nil) :< Leaf leaf
|
||||||
|
|
||||||
{-
|
{-
|
||||||
@ -57,11 +57,11 @@ Example (from GHCi):
|
|||||||
> Leaf "example"
|
> Leaf "example"
|
||||||
|
|
||||||
-}
|
-}
|
||||||
leafTerm :: leaf -> Cofree (Syntax leaf) (Record '[Range, Category])
|
leafTerm :: Text -> Cofree Syntax (Record '[Range, Category])
|
||||||
leafTerm = cofree . leafTermF
|
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)
|
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
|
indexedTerm leaves = cofree $ indexedTermF leaves
|
||||||
|
@ -23,9 +23,9 @@ import Term
|
|||||||
|
|
||||||
|
|
||||||
-- | Diff two terms recursively, given functions characterizing the diffing.
|
-- | Diff two terms recursively, given functions characterizing the diffing.
|
||||||
diffTerms :: (Eq leaf, Hashable leaf, HasField fields Category)
|
diffTerms :: HasField fields Category
|
||||||
=> Both (SyntaxTerm leaf fields) -- ^ A pair of terms representing the old and new state, respectively.
|
=> Both (SyntaxTerm leaf fields) -- ^ A pair of terms representing the old and new state, respectively.
|
||||||
-> SyntaxDiff leaf fields
|
-> SyntaxDiff leaf fields
|
||||||
diffTerms = decoratingWith getLabel (diffTermsWith algorithmWithTerms comparableByCategory)
|
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.
|
-- | Diff two terms by decorating with feature vectors computed using the supplied labelling algebra, and stripping the feature vectors from the resulting diff.
|
||||||
@ -55,7 +55,7 @@ diffTermsWith refine comparable (Join (a, b)) = runFreer decompose (diff a b)
|
|||||||
Replace a b -> pure (replacing a b)
|
Replace a b -> pure (replacing a b)
|
||||||
|
|
||||||
-- | Compute the label for a given term, suitable for inclusion in a _p_,_q_-gram.
|
-- | 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
|
getLabel (h :< t) = (Info.category h, case t of
|
||||||
Leaf s -> Just s
|
Leaf s -> Just s
|
||||||
_ -> Nothing)
|
_ -> Nothing)
|
||||||
|
@ -36,7 +36,7 @@ languageForType mediaType = case mediaType of
|
|||||||
".py" -> Just Python
|
".py" -> Just Python
|
||||||
_ -> Nothing
|
_ -> 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
|
toVarDeclOrAssignment child = case unwrap child of
|
||||||
S.Indexed [child', assignment] -> cofree $ setCategory (extract child) VarAssignment :< S.VarAssignment [child'] assignment
|
S.Indexed [child', assignment] -> cofree $ setCategory (extract child) VarAssignment :< S.VarAssignment [child'] assignment
|
||||||
S.Indexed [child'] -> cofree $ setCategory (extract child) VarDecl :< S.VarDecl [child']
|
S.Indexed [child'] -> cofree $ setCategory (extract child) VarDecl :< S.VarDecl [child']
|
||||||
@ -44,22 +44,22 @@ toVarDeclOrAssignment child = case unwrap child of
|
|||||||
S.VarAssignment _ _ -> child
|
S.VarAssignment _ _ -> child
|
||||||
_ -> toVarDecl 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]
|
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.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.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 | S.Leaf c <- unwrap child = [cofree (extract child :< S.Comment c)]
|
||||||
toTuple child = pure child
|
toTuple child = pure child
|
||||||
|
|
||||||
toPublicFieldDefinition :: HasField fields Category => [SyntaxTerm Text fields] -> Maybe (S.Syntax Text (SyntaxTerm Text fields))
|
toPublicFieldDefinition :: HasField fields Category => [SyntaxTerm Text fields] -> Maybe (S.Syntax (SyntaxTerm Text fields))
|
||||||
toPublicFieldDefinition children = case break (\x -> category (extract x) == Identifier) children of
|
toPublicFieldDefinition children = case break (\x -> category (extract x) == Identifier) children of
|
||||||
(prev, [identifier, assignment]) -> Just $ S.VarAssignment (prev ++ [identifier]) assignment
|
(prev, [identifier, assignment]) -> Just $ S.VarAssignment (prev ++ [identifier]) assignment
|
||||||
(_, [_]) -> Just $ S.VarDecl children
|
(_, [_]) -> Just $ S.VarDecl children
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
|
||||||
toInterface :: HasField fields Category => [SyntaxTerm Text fields] -> Maybe (S.Syntax Text (SyntaxTerm Text fields))
|
toInterface :: HasField fields Category => [SyntaxTerm Text fields] -> Maybe (S.Syntax (SyntaxTerm Text fields))
|
||||||
toInterface (id : rest) = case break (\x -> category (extract x) == Other "object_type") rest of
|
toInterface (id : rest) = case break (\x -> category (extract x) == Other "object_type") rest of
|
||||||
(clauses, [body]) -> Just $ S.Interface id clauses (toList (unwrap body))
|
(clauses, [body]) -> Just $ S.Interface id clauses (toList (unwrap body))
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
@ -11,7 +11,7 @@ termAssignment
|
|||||||
:: Source -- ^ The source of the term.
|
:: Source -- ^ The source of the term.
|
||||||
-> Category -- ^ The category for the term.
|
-> Category -- ^ The category for the term.
|
||||||
-> [ SyntaxTerm Text DefaultFields ] -- ^ The child nodes of the term.
|
-> [ SyntaxTerm Text DefaultFields ] -- ^ The child nodes of the term.
|
||||||
-> Maybe (S.Syntax Text (SyntaxTerm Text DefaultFields)) -- ^ The resulting term, in Maybe.
|
-> Maybe (S.Syntax (SyntaxTerm Text DefaultFields)) -- ^ The resulting term, in Maybe.
|
||||||
termAssignment _ _ _ = Nothing
|
termAssignment _ _ _ = Nothing
|
||||||
|
|
||||||
|
|
||||||
|
@ -11,7 +11,7 @@ termAssignment
|
|||||||
:: Source -- ^ The source of the term.
|
:: Source -- ^ The source of the term.
|
||||||
-> Category -- ^ The category for the term.
|
-> Category -- ^ The category for the term.
|
||||||
-> [ SyntaxTerm Text DefaultFields ] -- ^ The child nodes of the term.
|
-> [ SyntaxTerm Text DefaultFields ] -- ^ The child nodes of the term.
|
||||||
-> Maybe (S.Syntax Text (SyntaxTerm Text DefaultFields)) -- ^ The resulting term, in Maybe.
|
-> Maybe (S.Syntax (SyntaxTerm Text DefaultFields)) -- ^ The resulting term, in Maybe.
|
||||||
termAssignment source category children = case (category, children) of
|
termAssignment source category children = case (category, children) of
|
||||||
(Module, [moduleName]) -> Just $ S.Module moduleName []
|
(Module, [moduleName]) -> Just $ S.Module moduleName []
|
||||||
(Import, [importName]) -> Just $ S.Import importName []
|
(Import, [importName]) -> Just $ S.Import importName []
|
||||||
|
@ -13,7 +13,7 @@ termAssignment
|
|||||||
:: Source -- ^ The source of the term.
|
:: Source -- ^ The source of the term.
|
||||||
-> Category -- ^ The category for the term.
|
-> Category -- ^ The category for the term.
|
||||||
-> [ SyntaxTerm Text DefaultFields ] -- ^ The child nodes of the term.
|
-> [ SyntaxTerm Text DefaultFields ] -- ^ The child nodes of the term.
|
||||||
-> Maybe (S.Syntax Text (SyntaxTerm Text DefaultFields)) -- ^ The resulting term, in Maybe.
|
-> Maybe (S.Syntax (SyntaxTerm Text DefaultFields)) -- ^ The resulting term, in Maybe.
|
||||||
termAssignment _ category children
|
termAssignment _ category children
|
||||||
= case (category, children) of
|
= case (category, children) of
|
||||||
(ArgumentPair, [ k, v ] ) -> Just $ S.Pair k v
|
(ArgumentPair, [ k, v ] ) -> Just $ S.Pair k v
|
||||||
|
@ -12,7 +12,7 @@ termAssignment
|
|||||||
:: Source -- ^ The source of the term.
|
:: Source -- ^ The source of the term.
|
||||||
-> Category -- ^ The category for the term.
|
-> Category -- ^ The category for the term.
|
||||||
-> [ SyntaxTerm Text DefaultFields ] -- ^ The child nodes of the term.
|
-> [ SyntaxTerm Text DefaultFields ] -- ^ The child nodes of the term.
|
||||||
-> Maybe (S.Syntax Text (SyntaxTerm Text DefaultFields)) -- ^ The resulting term, in Maybe.
|
-> Maybe (S.Syntax (SyntaxTerm Text DefaultFields)) -- ^ The resulting term, in Maybe.
|
||||||
termAssignment _ category children =
|
termAssignment _ category children =
|
||||||
case (category, children) of
|
case (category, children) of
|
||||||
(Assignment, [ identifier, value ]) -> Just $ S.Assignment identifier value
|
(Assignment, [ identifier, value ]) -> Just $ S.Assignment identifier value
|
||||||
|
@ -70,7 +70,7 @@ data SomeRenderer f where
|
|||||||
|
|
||||||
deriving instance Show (SomeRenderer f)
|
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
|
identifierAlgebra (_ :< syntax) = case syntax of
|
||||||
S.Assignment f _ -> identifier f
|
S.Assignment f _ -> identifier f
|
||||||
S.Class 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
|
instance ToJSON a => ToJSONFields [a] where
|
||||||
toJSONFields list = [ "children" .= list ]
|
toJSONFields list = [ "children" .= list ]
|
||||||
|
|
||||||
instance ToJSON recur => ToJSONFields (Syntax leaf recur) where
|
instance ToJSON recur => ToJSONFields (Syntax recur) where
|
||||||
toJSONFields syntax = [ "children" .= toList syntax ]
|
toJSONFields syntax = [ "children" .= toList syntax ]
|
||||||
|
|
||||||
instance (Foldable f, ToJSON a, ToJSONFields (Union fs a)) => ToJSONFields (Union (f ': fs) a) where
|
instance (Foldable f, ToJSON a, ToJSONFields (Union fs a)) => ToJSONFields (Union (f ': fs) a) where
|
||||||
|
@ -24,4 +24,4 @@ getRange diff = byteRange $ case runFree diff of
|
|||||||
|
|
||||||
-- | A diff with only one side’s annotations.
|
-- | A diff with only one side’s annotations.
|
||||||
type SplitDiff f annotation = Free (TermF f annotation) (SplitPatch (Term f annotation))
|
type SplitDiff f annotation = Free (TermF f annotation) (SplitPatch (Term f annotation))
|
||||||
type SplitSyntaxDiff leaf fields = SplitDiff (Syntax leaf) (Record fields)
|
type SplitSyntaxDiff leaf fields = SplitDiff Syntax (Record fields)
|
||||||
|
@ -7,6 +7,7 @@ import Data.Functor.Classes
|
|||||||
import Data.Functor.Classes.Eq.Generic
|
import Data.Functor.Classes.Eq.Generic
|
||||||
import Data.Functor.Listable
|
import Data.Functor.Listable
|
||||||
import Data.Mergeable
|
import Data.Mergeable
|
||||||
|
import Data.Text (pack)
|
||||||
import GHC.Generics
|
import GHC.Generics
|
||||||
import Prologue
|
import Prologue
|
||||||
|
|
||||||
@ -14,9 +15,9 @@ import Prologue
|
|||||||
--
|
--
|
||||||
-- 'a' is the type of leaves in the syntax tree, typically 'Text', but possibly some datatype representing different leaves more precisely.
|
-- '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.
|
-- '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.
|
-- | 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.
|
-- | 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]
|
| Indexed [f]
|
||||||
-- | An ordered branch of child nodes, expected to be of fixed length in the grammar, e.g. a binary operator & its operands.
|
-- | An ordered branch of child nodes, expected to be of fixed length in the grammar, e.g. a binary operator & its operands.
|
||||||
@ -57,7 +58,7 @@ data Syntax a f
|
|||||||
-- | A pair in an Object. e.g. foo: bar or foo => bar
|
-- | A pair in an Object. e.g. foo: bar or foo => bar
|
||||||
| Pair f f
|
| Pair f f
|
||||||
-- | A comment.
|
-- | A comment.
|
||||||
| Comment a
|
| Comment Text
|
||||||
-- | A term preceded or followed by any number of comments.
|
-- | A term preceded or followed by any number of comments.
|
||||||
| Commented [f] (Maybe f)
|
| Commented [f] (Maybe f)
|
||||||
| ParseError [f]
|
| ParseError [f]
|
||||||
@ -113,16 +114,16 @@ data Syntax a f
|
|||||||
deriving (Eq, Foldable, Functor, Generic, Generic1, Mergeable, Ord, Show, Traversable, ToJSON, NFData)
|
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
|
extractLeafValue syntax = case syntax of
|
||||||
Leaf a -> Just a
|
Leaf a -> Just a
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
|
||||||
-- Instances
|
-- Instances
|
||||||
|
|
||||||
instance Listable2 Syntax where
|
instance Listable1 Syntax where
|
||||||
liftTiers2 leaf recur
|
liftTiers recur
|
||||||
= liftCons1 leaf Leaf
|
= liftCons1 (pack `mapT` tiers) Leaf
|
||||||
\/ liftCons1 (liftTiers recur) Indexed
|
\/ liftCons1 (liftTiers recur) Indexed
|
||||||
\/ liftCons1 (liftTiers recur) Fixed
|
\/ liftCons1 (liftTiers recur) Fixed
|
||||||
\/ liftCons3 recur (liftTiers recur) (liftTiers recur) FunctionCall
|
\/ liftCons3 recur (liftTiers recur) (liftTiers recur) FunctionCall
|
||||||
@ -142,7 +143,7 @@ instance Listable2 Syntax where
|
|||||||
\/ liftCons1 (liftTiers recur) Select
|
\/ liftCons1 (liftTiers recur) Select
|
||||||
\/ liftCons2 (liftTiers recur) (liftTiers recur) Syntax.Object
|
\/ liftCons2 (liftTiers recur) (liftTiers recur) Syntax.Object
|
||||||
\/ liftCons2 recur recur Pair
|
\/ liftCons2 recur recur Pair
|
||||||
\/ liftCons1 leaf Comment
|
\/ liftCons1 (pack `mapT` tiers) Comment
|
||||||
\/ liftCons2 (liftTiers recur) (liftTiers recur) Commented
|
\/ liftCons2 (liftTiers recur) (liftTiers recur) Commented
|
||||||
\/ liftCons1 (liftTiers recur) Syntax.ParseError
|
\/ liftCons1 (liftTiers recur) Syntax.ParseError
|
||||||
\/ liftCons2 (liftTiers recur) (liftTiers recur) For
|
\/ liftCons2 (liftTiers recur) (liftTiers recur) For
|
||||||
@ -177,13 +178,10 @@ instance Listable2 Syntax where
|
|||||||
\/ liftCons2 recur recur Send
|
\/ liftCons2 recur recur Send
|
||||||
\/ liftCons1 (liftTiers recur) DefaultCase
|
\/ liftCons1 (liftTiers recur) DefaultCase
|
||||||
|
|
||||||
instance Listable leaf => Listable1 (Syntax leaf) where
|
instance Listable recur => Listable (Syntax recur) where
|
||||||
liftTiers = liftTiers2 tiers
|
|
||||||
|
|
||||||
instance (Listable leaf, Listable recur) => Listable (Syntax leaf recur) where
|
|
||||||
tiers = tiers1
|
tiers = tiers1
|
||||||
|
|
||||||
instance Eq leaf => Eq1 (Syntax leaf) where
|
instance Eq1 Syntax where
|
||||||
liftEq = genericLiftEq
|
liftEq = genericLiftEq
|
||||||
|
|
||||||
instance Eq leaf => GAlign (Syntax leaf)
|
instance GAlign Syntax
|
||||||
|
@ -14,8 +14,8 @@ type Term f = Cofree f
|
|||||||
type TermF = CofreeF
|
type TermF = CofreeF
|
||||||
|
|
||||||
-- | A Term with a Syntax leaf and a record of fields.
|
-- | A Term with a Syntax leaf and a record of fields.
|
||||||
type SyntaxTerm leaf fields = Term (Syntax leaf) (Record fields)
|
type SyntaxTerm leaf fields = Term Syntax (Record fields)
|
||||||
type SyntaxTermF leaf fields = TermF (Syntax leaf) (Record fields)
|
type SyntaxTermF leaf fields = TermF Syntax (Record fields)
|
||||||
|
|
||||||
instance (NFData (f (Cofree f a)), NFData a, Functor f) => NFData (Cofree f a) where
|
instance (NFData (f (Cofree f a)), NFData a, Functor f) => NFData (Cofree f a) where
|
||||||
rnf = rnf . runCofree
|
rnf = rnf . runCofree
|
||||||
|
@ -110,7 +110,7 @@ assignTerm language source annotation children allChildren =
|
|||||||
cofree . (annotation :<) <$> case assignTermByLanguage source (category annotation) children of
|
cofree . (annotation :<) <$> case assignTermByLanguage source (category annotation) children of
|
||||||
Just a -> pure a
|
Just a -> pure a
|
||||||
_ -> defaultTermAssignment source (category annotation) children allChildren
|
_ -> 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 Text DefaultFields ] -> Maybe (S.Syntax (SyntaxTerm Text DefaultFields))
|
||||||
assignTermByLanguage = case languageForTSLanguage language of
|
assignTermByLanguage = case languageForTSLanguage language of
|
||||||
Just C -> C.termAssignment
|
Just C -> C.termAssignment
|
||||||
Just Language.Go -> Go.termAssignment
|
Just Language.Go -> Go.termAssignment
|
||||||
@ -118,7 +118,7 @@ assignTerm language source annotation children allChildren =
|
|||||||
Just TypeScript -> TS.termAssignment
|
Just TypeScript -> TS.termAssignment
|
||||||
_ -> \ _ _ _ -> Nothing
|
_ -> \ _ _ _ -> Nothing
|
||||||
|
|
||||||
defaultTermAssignment :: Source -> Category -> [ SyntaxTerm Text DefaultFields ] -> IO [ SyntaxTerm Text DefaultFields ] -> IO (S.Syntax Text (SyntaxTerm Text DefaultFields))
|
defaultTermAssignment :: Source -> Category -> [ SyntaxTerm Text DefaultFields ] -> IO [ SyntaxTerm Text DefaultFields ] -> IO (S.Syntax (SyntaxTerm Text DefaultFields))
|
||||||
defaultTermAssignment source category children allChildren
|
defaultTermAssignment source category children allChildren
|
||||||
| category `elem` operatorCategories = S.Operator <$> allChildren
|
| category `elem` operatorCategories = S.Operator <$> allChildren
|
||||||
| otherwise = pure $! case (category, children) of
|
| otherwise = pure $! case (category, children) of
|
||||||
|
@ -31,7 +31,7 @@ spec :: Spec
|
|||||||
spec = parallel $ do
|
spec = parallel $ do
|
||||||
describe "alignBranch" $ do
|
describe "alignBranch" $ do
|
||||||
it "produces symmetrical context" $
|
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, [])
|
[ Join (These (Range 0 2, [])
|
||||||
(Range 0 2, []))
|
(Range 0 2, []))
|
||||||
, Join (These (Range 2 4, [])
|
, Join (These (Range 2 4, [])
|
||||||
@ -39,7 +39,7 @@ spec = parallel $ do
|
|||||||
]
|
]
|
||||||
|
|
||||||
it "produces asymmetrical context" $
|
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, [])
|
[ Join (These (Range 0 2, [])
|
||||||
(Range 0 1, []))
|
(Range 0 1, []))
|
||||||
, Join (This (Range 2 4, []))
|
, Join (This (Range 2 4, []))
|
||||||
@ -256,7 +256,7 @@ instance Listable BranchElement where
|
|||||||
counts :: [Join These (Int, a)] -> Both Int
|
counts :: [Join These (Int, a)] -> Both Int
|
||||||
counts numbered = fromMaybe 0 . getLast . mconcat . fmap Last <$> Join (unalign (runJoin . fmap Prologue.fst <$> numbered))
|
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
|
align sources = PrettyDiff sources . fmap (fmap (getRange &&& identity)) . alignDiff sources . deconstruct
|
||||||
|
|
||||||
info :: Int -> Int -> Record '[Range]
|
info :: Int -> Int -> Record '[Range]
|
||||||
@ -281,14 +281,14 @@ newtype ConstructibleFree f patch annotation = ConstructibleFree { deconstruct :
|
|||||||
|
|
||||||
|
|
||||||
class PatchConstructible p where
|
class PatchConstructible p where
|
||||||
insert :: Term (Syntax Text) (Record '[Range]) -> p
|
insert :: Term Syntax (Record '[Range]) -> p
|
||||||
delete :: Term (Syntax Text) (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
|
insert = Insert
|
||||||
delete = Delete
|
delete = Delete
|
||||||
|
|
||||||
instance PatchConstructible (SplitPatch (Term (Syntax Text) (Record '[Range]))) where
|
instance PatchConstructible (SplitPatch (Term Syntax (Record '[Range]))) where
|
||||||
insert = SplitInsert
|
insert = SplitInsert
|
||||||
delete = SplitDelete
|
delete = SplitDelete
|
||||||
|
|
||||||
@ -304,7 +304,7 @@ class SyntaxConstructible s where
|
|||||||
leaf :: annotation -> Text -> s annotation
|
leaf :: annotation -> Text -> s annotation
|
||||||
branch :: annotation -> [s annotation] -> 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
|
leaf info = ConstructibleFree . free . Free . (info :<) . Leaf
|
||||||
branch info = ConstructibleFree . free . Free . (info :<) . Indexed . fmap deconstruct
|
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 []
|
leaf info = ConstructibleFree . free . Free . (info :<) . const []
|
||||||
branch info = ConstructibleFree . free . Free . (info :<) . fmap deconstruct
|
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 `leaf` value = cofree $ info :< Leaf value
|
||||||
info `branch` children = cofree $ info :< Indexed children
|
info `branch` children = cofree $ info :< Indexed children
|
||||||
|
|
||||||
|
@ -24,8 +24,8 @@ spec = parallel $ do
|
|||||||
withAlternativeInstances sequenceAltLaws (Identity `mapT` tiers :: [Tier (Identity Char)])
|
withAlternativeInstances sequenceAltLaws (Identity `mapT` tiers :: [Tier (Identity Char)])
|
||||||
withAlternativeInstances mergeLaws (Identity `mapT` tiers :: [Tier (Identity Char)])
|
withAlternativeInstances mergeLaws (Identity `mapT` tiers :: [Tier (Identity Char)])
|
||||||
describe "Syntax" $ do
|
describe "Syntax" $ do
|
||||||
withAlternativeInstances sequenceAltLaws (tiers :: [Tier (Syntax Char Char)])
|
withAlternativeInstances sequenceAltLaws (tiers :: [Tier (Syntax Char)])
|
||||||
withAlternativeInstances mergeLaws (tiers :: [Tier (Syntax Char Char)])
|
withAlternativeInstances mergeLaws (tiers :: [Tier (Syntax Char)])
|
||||||
|
|
||||||
prop "subsumes catMaybes/Just" $
|
prop "subsumes catMaybes/Just" $
|
||||||
\ a -> sequenceAlt a `shouldBe` pure (catMaybes (a :: [Maybe Char]))
|
\ a -> sequenceAlt a `shouldBe` pure (catMaybes (a :: [Maybe Char]))
|
||||||
|
@ -41,7 +41,7 @@ spec = parallel $ do
|
|||||||
(beforeTerm diff, afterTerm diff) `shouldBe` (Just (root (stripTerm <$> tas)), Just (root (stripTerm <$> tbs)))
|
(beforeTerm diff, afterTerm diff) `shouldBe` (Just (root (stripTerm <$> tas)), Just (root (stripTerm <$> tbs)))
|
||||||
|
|
||||||
it "produces unbiased insertions within branches" $
|
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 ]
|
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
|
where canCompare a b = headF a == headF b
|
||||||
|
@ -21,7 +21,7 @@ spec :: Spec
|
|||||||
spec = parallel $ do
|
spec = parallel $ do
|
||||||
describe "interpret" $ do
|
describe "interpret" $ do
|
||||||
it "returns a replacement when comparing two unicode equivalent terms" $
|
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
|
termB = cofree $ (StringLiteral :. Nil) :< Leaf "\7831" in
|
||||||
diffTerms (both termA termB) `shouldBe` replacing termA termB
|
diffTerms (both termA termB) `shouldBe` replacing termA termB
|
||||||
|
|
||||||
|
@ -34,21 +34,21 @@ spec :: Spec
|
|||||||
spec = parallel $ do
|
spec = parallel $ do
|
||||||
describe "tableOfContentsBy" $ do
|
describe "tableOfContentsBy" $ do
|
||||||
prop "drops all nodes with the constant Nothing function" $
|
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 diffSize = max 1 . sum . fmap (const 1)
|
||||||
let lastValue a = fromMaybe (extract a) (getLast (foldMap (Last . Just) a))
|
let lastValue a = fromMaybe (extract a) (getLast (foldMap (Last . Just) a))
|
||||||
prop "includes all nodes with a constant Just function" $
|
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" $
|
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" $
|
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" $
|
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`
|
tableOfContentsBy (\ (n :< _) -> if n == 0 then Just n else Nothing) diff' `shouldBe`
|
||||||
if Prologue.null diff' then [Unchanged 0]
|
if Prologue.null diff' then [Unchanged 0]
|
||||||
else replicate (length diff') (Changed 0)
|
else replicate (length diff') (Changed 0)
|
||||||
@ -200,7 +200,7 @@ functionInfo :: Record DefaultFields
|
|||||||
functionInfo = Range 0 0 :. C.Function :. sourceSpanBetween (0,0) (0,0) :. Nil
|
functionInfo = Range 0 0 :. C.Function :. sourceSpanBetween (0,0) (0,0) :. Nil
|
||||||
|
|
||||||
-- Filter tiers for terms that we consider "meaniningful" in TOC summaries.
|
-- 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
|
isMeaningfulTerm a = case runCofree (unListableF a) of
|
||||||
(_ :< S.Indexed _) -> False
|
(_ :< S.Indexed _) -> False
|
||||||
(_ :< S.Fixed _) -> False
|
(_ :< S.Fixed _) -> False
|
||||||
@ -209,7 +209,7 @@ isMeaningfulTerm a = case runCofree (unListableF a) of
|
|||||||
_ -> True
|
_ -> True
|
||||||
|
|
||||||
-- Filter tiers for terms if the Syntax is a Method or a Function.
|
-- 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
|
isMethodOrFunction a = case runCofree (unListableF a) of
|
||||||
(_ :< S.Method{}) -> True
|
(_ :< S.Method{}) -> True
|
||||||
(_ :< S.Function{}) -> True
|
(_ :< S.Function{}) -> True
|
||||||
|
Loading…
Reference in New Issue
Block a user