mirror of
https://github.com/github/semantic.git
synced 2024-12-29 01:42:43 +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 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 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 leaf fields) -- ^ A pair of terms representing the old and new state, respectively.
|
||||
-> SyntaxDiff leaf 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,7 +55,7 @@ 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)
|
||||
|
@ -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 Text fields] -> Maybe (S.Syntax (SyntaxTerm Text 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 Text fields] -> Maybe (S.Syntax (SyntaxTerm Text 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
|
||||
|
@ -11,7 +11,7 @@ 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.
|
||||
-> Maybe (S.Syntax (SyntaxTerm Text DefaultFields)) -- ^ The resulting term, in Maybe.
|
||||
termAssignment _ _ _ = Nothing
|
||||
|
||||
|
||||
|
@ -11,7 +11,7 @@ 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.
|
||||
-> Maybe (S.Syntax (SyntaxTerm Text 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 []
|
||||
|
@ -13,7 +13,7 @@ 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.
|
||||
-> Maybe (S.Syntax (SyntaxTerm Text DefaultFields)) -- ^ The resulting term, in Maybe.
|
||||
termAssignment _ category children
|
||||
= case (category, children) of
|
||||
(ArgumentPair, [ k, v ] ) -> Just $ S.Pair k v
|
||||
|
@ -12,7 +12,7 @@ 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.
|
||||
-> Maybe (S.Syntax (SyntaxTerm Text DefaultFields)) -- ^ The resulting term, in Maybe.
|
||||
termAssignment _ category children =
|
||||
case (category, children) of
|
||||
(Assignment, [ identifier, value ]) -> Just $ S.Assignment identifier value
|
||||
|
@ -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
|
||||
|
@ -24,4 +24,4 @@ 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)
|
||||
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.Listable
|
||||
import Data.Mergeable
|
||||
import Data.Text (pack)
|
||||
import GHC.Generics
|
||||
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.
|
||||
-- '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.
|
||||
@ -57,7 +58,7 @@ data Syntax a 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]
|
||||
@ -113,16 +114,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 +143,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 +178,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 leaf fields = Term Syntax (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
|
||||
rnf = rnf . runCofree
|
||||
|
@ -110,7 +110,7 @@ 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 Text DefaultFields ] -> Maybe (S.Syntax (SyntaxTerm Text 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 Text DefaultFields ] -> IO [ SyntaxTerm Text DefaultFields ] -> IO (S.Syntax (SyntaxTerm Text 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]))
|
||||
|
@ -41,7 +41,7 @@ spec = parallel $ do
|
||||
(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
|
||||
|
@ -21,7 +21,7 @@ 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
|
||||
|
||||
|
@ -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)
|
||||
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user