github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-18 04:11:48 +03:00
Code Issues Projects Releases Wiki Activity

Merge branch 'better-record-pattern-matches' into consolidate-common-term-assignment-patterns

Browse Source
This commit is contained in:
Rob Rix 2017-01-19 16:00:12 -05:00
parent abe529534a
commit 3f60857321
17 changed files with 77 additions and 81 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
src/Data/RandomWalkSimilarity.hs
View File

@ -74,18 +74,18 @@ rws compare getLabel as bs
(featurizedAs, featurizedBs, _, _, countersAndDiffs, allDiffs) =
foldl' (\(as, bs, counterA, counterB, diffs, allDiffs) diff -> case runFree diff of
Pure (Right (Delete term)) ->
(as <> pure (featurize counterA term), bs, succ counterA, counterB, diffs, allDiffs <> pure Nil)
(as <> pure (featurize counterA term), bs, succ counterA, counterB, diffs, allDiffs <> pure None)
Pure (Right (Insert term)) ->
(as, bs <> pure (featurize counterB term), counterA, succ counterB, diffs, allDiffs <> pure (Term (featurize counterB term)))
syntax -> let diff' = free syntax >>= either identity pure in
(as, bs, succ counterA, succ counterB, diffs <> pure (These counterA counterB, diff'), allDiffs <> pure (Index counterA))
) ([], [], 0, 0, [], []) sesDiffs
findNearestNeighbourToDiff :: TermOrIndexOrNil (UnmappedTerm f fields)
findNearestNeighbourToDiff :: TermOrIndexOrNone (UnmappedTerm f fields)
-> State (Int, UnmappedTerms f fields, UnmappedTerms f fields)
(Maybe (These Int Int, Diff f (Record fields)))
findNearestNeighbourToDiff termThing = case termThing of
Nil -> pure Nothing
None -> pure Nothing
Term term -> Just <$> findNearestNeighbourTo term
Index i -> do
(_, unA, unB) <- get
@ -224,7 +224,7 @@ data UnmappedTerm f fields = UnmappedTerm {
}
-- | Either a `term`, an index of a matched term, or nil.
data TermOrIndexOrNil term = Term term | Index Int | Nil
data TermOrIndexOrNone term = Term term | Index Int | None
-- | An IntMap of unmapped terms keyed by their position in a list of terms.
type UnmappedTerms f fields = IntMap (UnmappedTerm f fields)
@ -244,8 +244,8 @@ defaultFeatureVectorDecorator getLabel = featureVectorDecorator getLabel default
-- | Annotates a term with a feature vector at each node, parameterized by stem length, base width, and feature vector dimensions.
featureVectorDecorator :: (Hashable label, Traversable f) => Label f fields label -> Int -> Int -> Int -> Term f (Record fields) -> Term f (Record (Vector.Vector Double ': fields))
featureVectorDecorator getLabel p q d
= cata (\ (RCons gram rest :< functor) ->
cofree ((foldr (Vector.zipWith (+) . getField . extract) (unitVector d (hash gram)) functor .: rest) :< functor))
= cata (\ ((gram :. rest) :< functor) ->
cofree ((foldr (Vector.zipWith (+) . getField . extract) (unitVector d (hash gram)) functor :. rest) :< functor))
. pqGramDecorator getLabel p q
-- | Annotates a term with the corresponding p,q-gram at each node.
@ -259,7 +259,7 @@ pqGramDecorator
pqGramDecorator getLabel p q = cata algebra
where
algebra term = let label = getLabel term in
cofree ((gram label .: headF term) :< assignParentAndSiblingLabels (tailF term) label)
cofree ((gram label :. headF term) :< assignParentAndSiblingLabels (tailF term) label)
gram label = Gram (padToSize p []) (padToSize q (pure (Just label)))
assignParentAndSiblingLabels functor label = (`evalState` (replicate (q `div` 2) Nothing <> siblingLabels functor)) (for functor (assignLabels label))
@ -267,10 +267,10 @@ pqGramDecorator getLabel p q = cata algebra
-> Term f (Record (Gram label ': fields))
-> State [Maybe label] (Term f (Record (Gram label ': fields)))
assignLabels label a = case runCofree a of
RCons gram rest :< functor -> do
(gram :. rest) :< functor -> do
labels <- get
put (drop 1 labels)
pure $! cofree ((gram { stem = padToSize p (Just label : stem gram), base = padToSize q labels } .: rest) :< functor)
pure $! cofree ((gram { stem = padToSize p (Just label : stem gram), base = padToSize q labels } :. rest) :< functor)
siblingLabels :: Traversable f => f (Term f (Record (Gram label ': fields))) -> [Maybe label]
siblingLabels = foldMap (base . rhead . extract)
padToSize n list = take n (list <> repeat empty)

36
src/Data/Record.hs
View File

@ -17,22 +17,18 @@ type DefaultFields fields = (HasField fields Category, HasField fields Range, Ha
-- |
-- | This is heavily inspired by Aaron Levin’s [Extensible Effects in the van Laarhoven Free Monad](http://aaronlevin.ca/post/136494428283/extensible-effects-in-the-van-laarhoven-free-monad).
data Record :: [*] -> * where
RNil :: Record '[]
RCons :: h -> Record t -> Record (h ': t)
Nil :: Record '[]
(:.) :: h -> Record t -> Record (h ': t)
infixr 0 .:
-- | Infix synonym for `RCons`: `a .: b .: RNil == RCons a (RCons b RNil)`.
(.:) :: h -> Record t -> Record (h ': t)
(.:) = RCons
infixr 0 :.
-- | Get the first element of a non-empty record.
rhead :: Record (head ': tail) -> head
rhead (RCons head _) = head
rhead (head :. _) = head
-- | Get the first element of a non-empty record.
rtail :: Record (head ': tail) -> Record tail
rtail (RCons _ tail) = tail
rtail (_ :. tail) = tail
-- Classes
@ -48,19 +44,19 @@ class HasField (fields :: [*]) (field :: *) where
-- OVERLAPPABLE is required for the HasField instances so that we can handle the two cases: either the head of the non-empty h-list is the requested field, or it isn’t. The third possible case (the h-list is empty) is rejected at compile-time.
instance {-# OVERLAPPABLE #-} HasField fields field => HasField (notIt ': fields) field where
getField (RCons _ t) = getField t
setField (RCons h t) f = RCons h (setField t f)
getField (_ :. t) = getField t
setField (h :. t) f = h :. setField t f
instance {-# OVERLAPPABLE #-} HasField (field ': fields) field where
getField (RCons h _) = h
setField (RCons _ t) f = RCons f t
getField (h :. _) = h
setField (_ :. t) f = f :. t
instance (Show h, Show (Record t)) => Show (Record (h ': t)) where
showsPrec n (RCons h t) = showParen (n > 0) $ showsPrec 1 h . (" .: " <>) . shows t
showsPrec n (h :. t) = showParen (n > 0) $ showsPrec 1 h . (" :. " <>) . shows t
instance Show (Record '[]) where
showsPrec n RNil = showParen (n > 0) ("RNil" <>)
showsPrec n Nil = showParen (n > 0) ("Nil" <>)
instance (ToJSON h, ToJSONList (Record t)) => ToJSON (Record (h ': t)) where
toJSON r = toJSONList (toJSONValues r)
@ -72,21 +68,21 @@ class ToJSONList t where
toJSONValues :: t -> [Value]
instance (ToJSON h, ToJSONList (Record t)) => ToJSONList (Record (h ': t)) where
toJSONValues (RCons h t) = toJSON h : toJSONValues t
toJSONValues (h :. t) = toJSON h : toJSONValues t
instance ToJSONList (Record '[]) where
toJSONValues _ = []
instance (Eq h, Eq (Record t)) => Eq (Record (h ': t)) where
RCons h1 t1 == RCons h2 t2 = h1 == h2 && t1 == t2
(h1 :. t1) == (h2 :. t2) = h1 == h2 && t1 == t2
instance Eq (Record '[]) where
_ == _ = True
instance (Ord h, Ord (Record t)) => Ord (Record (h ': t)) where
RCons h1 t1 `compare` RCons h2 t2 = let h = h1 `compare` h2 in
(h1 :. t1) `compare` (h2 :. t2) = let h = h1 `compare` h2 in
if h == EQ then t1 `compare` t2 else h
instance Ord (Record '[]) where
@ -94,7 +90,7 @@ instance Ord (Record '[]) where
instance (Listable head, Listable (Record tail)) => Listable (Record (head ': tail)) where
tiers = cons2 RCons
tiers = cons2 (:.)
instance Listable (Record '[]) where
tiers = cons0 RNil
tiers = cons0 Nil

46
src/FDoc/RecursionSchemes.hs
View File

@ -28,7 +28,7 @@ The example below adds a new field to the `Record` fields.
indexedTermAna :: [leaf] -> Term (Syntax leaf) (Record '[NewField, Range, Category])
indexedTermAna childrenLeaves = ana coalgebra (indexedTerm childrenLeaves)
where
coalgebra term = (NewField .: (extract term)) :< unwrap term
coalgebra term = (NewField :. (extract term)) :< unwrap term
{-
Catamorphism example -- add a new field to each term's Record fields
@ -47,7 +47,7 @@ indexedTermCata :: [leaf] -> Term (Syntax leaf) (Record '[NewField, Range, Categ
indexedTermCata childrenLeaves = cata algebra (indexedTerm childrenLeaves)
where
algebra :: CofreeF f (Record t) (Cofree f (Record (NewField : t))) -> Cofree f (Record (NewField : t))
algebra term = cofree $ (NewField .: (headF term)) :< tailF term
algebra term = cofree $ (NewField :. (headF term)) :< tailF term
{-
Anamorphism -- construct a Term from a string
@ -58,25 +58,25 @@ representation.
Example usage:
stringToTermAna "indexed" =>
CofreeT (Identity ( (Range {start = 1, end = 10} .: MethodCall .: RNil)
CofreeT (Identity ( (Range {start = 1, end = 10} :. MethodCall :. Nil)
:<
Indexed
[ CofreeT (Identity ( (Range {start = 1, end = 10} .: MethodCall .: RNil) :< Leaf "leaf1" ) )
, CofreeT (Identity ( (Range {start = 1, end = 10} .: MethodCall .: RNil) :< Leaf "leaf2" ) )
, CofreeT (Identity ( (Range {start = 1, end = 10} .: MethodCall .: RNil) :< Leaf "leaf3" ) )
[ CofreeT (Identity ( (Range {start = 1, end = 10} :. MethodCall :. Nil) :< Leaf "leaf1" ) )
, CofreeT (Identity ( (Range {start = 1, end = 10} :. MethodCall :. Nil) :< Leaf "leaf2" ) )
, CofreeT (Identity ( (Range {start = 1, end = 10} :. MethodCall :. Nil) :< Leaf "leaf3" ) )
] ))
First step is to match against the "indexed" string and begin building up a Cofree Indexed structure:
CofreeT (Identity ( (Range 1 10 .: Category.MethodCall .: RNil) :< Indexed ["leaf1", "leaf2", "leaf3"] ) )
CofreeT (Identity ( (Range 1 10 :. Category.MethodCall :. Nil) :< Indexed ["leaf1", "leaf2", "leaf3"] ) )
While building up the `Indexed` structure, we continue to recurse over the
`Indexed` terms ["leaf1", "leaf2", "leaf3"]. These are pattern matched using
the catch all `_` and default to `Leaf` Syntax shapes:
CofreeT (Identity ( (Range 1 10 .: Category.MethodCall .: RNil) :< Leaf "leaf1" ) )
CofreeT (Identity ( (Range 1 10 .: Category.MethodCall .: RNil) :< Leaf "leaf2" ) )
CofreeT (Identity ( (Range 1 10 .: Category.MethodCall .: RNil) :< Leaf "leaf3" ) )
CofreeT (Identity ( (Range 1 10 :. Category.MethodCall :. Nil) :< Leaf "leaf1" ) )
CofreeT (Identity ( (Range 1 10 :. Category.MethodCall :. Nil) :< Leaf "leaf2" ) )
CofreeT (Identity ( (Range 1 10 :. Category.MethodCall :. Nil) :< Leaf "leaf3" ) )
These structures are substituted in place of ["leaf1", "leaf2", "leaf3"] in
the new cofree `Indexed` structure, resulting in a expansion of all possible
@ -86,8 +86,8 @@ stringToTermAna :: String -> Term (Syntax String) (Record '[Range, Category])
stringToTermAna = ana coalgebra
where
coalgebra representation = case representation of
"indexed" -> (Range 1 10 .: Category.MethodCall .: RNil) :< Indexed ["leaf1", "leaf2", "leaf3"]
_ -> (Range 1 10 .: Category.MethodCall .: RNil) :< Leaf representation
"indexed" -> (Range 1 10 :. Category.MethodCall :. Nil) :< Indexed ["leaf1", "leaf2", "leaf3"]
_ -> (Range 1 10 :. Category.MethodCall :. Nil) :< Leaf representation
{-
Catamorphism -- construct a list of Strings from a recursive Term structure.
@ -131,8 +131,8 @@ stringTermHylo = hylo algebra coalgebra
(_ :< Indexed values) -> ["indexed"] <> Prologue.concat values
_ -> ["unknown"]
coalgebra stringRepresentation = case stringRepresentation of
"indexed" -> (Range 1 10 .: Category.MethodCall .: RNil) :< Indexed ["leaf1", "leaf2", "leaf3"]
_ -> (Range 1 10 .: Category.MethodCall .: RNil) :< Leaf stringRepresentation
"indexed" -> (Range 1 10 :. Category.MethodCall :. Nil) :< Indexed ["leaf1", "leaf2", "leaf3"]
_ -> (Range 1 10 :. Category.MethodCall :. Nil) :< Leaf stringRepresentation
{-
Paramorphism -- primitive recursion that maintains a reference to the original value and its computed value.
@ -158,22 +158,22 @@ Example Usage:
let terms = indexedTerm ["leaf1", "leaf2", "leaf3"]
termPara terms = Recurse over the structure to start at the leaves (bottom up traversal):
tuple3 = ( CofreeT (Identity ((Range {start = 1, end = 10} .: MethodCall .: RNil) :< Leaf "leaf3")), "leaf3" ) : []
tuple3 = ( CofreeT (Identity ((Range {start = 1, end = 10} :. MethodCall :. Nil) :< Leaf "leaf3")), "leaf3" ) : []
Continue the traversal from leaves to root:
tuple2:3 = ( CofreeT (Identity ((Range {start = 1, end = 10} .: MethodCall .: RNil) :< Leaf "leaf2")), "leaf2") : tuple3
tuple2:3 = ( CofreeT (Identity ((Range {start = 1, end = 10} :. MethodCall :. Nil) :< Leaf "leaf2")), "leaf2") : tuple3
tuple1:2:3 = ( CofreeT (Identity ((Range {start = 1, end = 10} .: MethodCall .: RNil) :< Leaf "leaf1" )), "leaf1") : tuple2:3
tuple1:2:3 = ( CofreeT (Identity ((Range {start = 1, end = 10} :. MethodCall :. Nil) :< Leaf "leaf1" )), "leaf1") : tuple2:3
Compute the root:
tupleIndexed:1:2:3 = ( CofreeT (Identity ((Range {start = 1, end = 10} .: MethodCall .: RNil) :< Indexed [])), "indexed" ) : tuple1:2:3
tupleIndexed:1:2:3 = ( CofreeT (Identity ((Range {start = 1, end = 10} :. MethodCall :. Nil) :< Indexed [])), "indexed" ) : tuple1:2:3
Final shape:
[ (CofreeT (Identity ((Range {start = 1, end = 10} .: MethodCall .: RNil) :< Indexed [])) , "indexed")
, (CofreeT (Identity ((Range {start = 1, end = 10} .: MethodCall .: RNil) :< Leaf "leaf1")), "leaf1")
, (CofreeT (Identity ((Range {start = 1, end = 10} .: MethodCall .: RNil) :< Leaf "leaf2")), "leaf2")
, (CofreeT (Identity ((Range {start = 1, end = 10} .: MethodCall .: RNil) :< Leaf "leaf3")), "leaf3")
[ (CofreeT (Identity ((Range {start = 1, end = 10} :. MethodCall :. Nil) :< Indexed [])) , "indexed")
, (CofreeT (Identity ((Range {start = 1, end = 10} :. MethodCall :. Nil) :< Leaf "leaf1")), "leaf1")
, (CofreeT (Identity ((Range {start = 1, end = 10} :. MethodCall :. Nil) :< Leaf "leaf2")), "leaf2")
, (CofreeT (Identity ((Range {start = 1, end = 10} :. MethodCall :. Nil) :< Leaf "leaf3")), "leaf3")
]
-}
@ -183,4 +183,4 @@ termPara = para algebra
algebra term = case term of
(annotation :< Leaf representation) -> [(cofree (annotation :< Leaf representation), representation)]
(annotation :< Indexed values) -> [(cofree (annotation :< Indexed []), "indexed")] <> (values >>= Prelude.snd)
_ -> [(cofree ((Range 1 10 .: Category.MethodCall .: RNil) :< Leaf "unknown"), "unknown")]
_ -> [(cofree ((Range 1 10 :. Category.MethodCall :. Nil) :< Leaf "unknown"), "unknown")]

8
src/FDoc/Term.hs
View File

@ -26,14 +26,14 @@ Example (from GHCi):
> let leaf = leafTermF "example"
> headF leaf
> Range {start = 1, end = 10} .: MethodCall .: RNil
> Range {start = 1, end = 10} :. MethodCall :. Nil
> tailF leaf
> Leaf "example"
-}
leafTermF :: leaf -> TermF (Syntax leaf) (Record '[Range, Category]) b
leafTermF leaf = (Range 1 10 .: Category.MethodCall .: RNil) :< Leaf leaf
leafTermF leaf = (Range 1 10 :. Category.MethodCall :. Nil) :< Leaf leaf
{-
@ -52,7 +52,7 @@ Example (from GHCi):
> let leaf = leafTerm "example"
> extract leaf
> Range {start = 1, end = 10} .: MethodCall .: RNil
> Range {start = 1, end = 10} :. MethodCall :. Nil
> unwrap leaf
> Leaf "example"
@ -61,7 +61,7 @@ leafTerm :: leaf -> Cofree (Syntax leaf) (Record '[Range, Category])
leafTerm = cofree . leafTermF
indexedTermF :: [leaf] -> TermF (Syntax leaf) (Record '[Range, Category]) (Term (Syntax leaf) (Record '[Range, Category]))
indexedTermF leaves = (Range 1 10 .: Category.MethodCall .: RNil) :< (Indexed (leafTerm <$> leaves))
indexedTermF leaves = (Range 1 10 :. Category.MethodCall :. Nil) :< (Indexed (leafTerm <$> leaves))
indexedTerm :: [leaf] -> Term (Syntax leaf) (Record '[Range, Category])
indexedTerm leaves = cofree $ indexedTermF leaves

2
src/Language.hs
View File

@ -56,7 +56,7 @@ termConstructor source sourceSpan category range children _ =
_ -> S.Indexed children
where
withDefaultInfo syntax =
pure $! cofree ((range .: category .: sourceSpan .: RNil) :< syntax)
pure $! cofree ((range :. category :. sourceSpan :. Nil) :< syntax)
toVarDecl :: (HasField fields Category) => Term (S.Syntax Text) (Record fields) -> Term (S.Syntax Text) (Record fields)
toVarDecl child = cofree $ setCategory (extract child) VarDecl :< S.VarDecl child Nothing

2
src/Language/C.hs
View File

@ -22,7 +22,7 @@ termConstructor source sourceSpan category range children _
[] -> S.Leaf . toText $ slice range source
_ -> S.Indexed children
where
withDefaultInfo syntax = pure $! cofree ((range .: category .: sourceSpan .: RNil) :< syntax)
withDefaultInfo syntax = pure $! cofree ((range :. category :. sourceSpan :. Nil) :< syntax)
categoryForCProductionName :: Text -> Category
categoryForCProductionName = Other

4
src/Language/Go.hs
View File

@ -236,10 +236,10 @@ termConstructor source sourceSpan category range children _ = pure $! case categ
let ranges' = getField . extract <$> terms
sourceSpans' = getField . extract <$> terms
in
cofree ((unionRangesFrom originalRange ranges' .: category' .: unionSourceSpansFrom sourceSpan sourceSpans' .: RNil) :< syntax)
cofree ((unionRangesFrom originalRange ranges' :. category' :. unionSourceSpansFrom sourceSpan sourceSpans' :. Nil) :< syntax)
withCategory category syntax =
cofree ((range .: category .: sourceSpan .: RNil) :< syntax)
cofree ((range :. category :. sourceSpan :. Nil) :< syntax)
withDefaultInfo = withCategory category

4
src/Language/JavaScript.hs
View File

@ -105,8 +105,8 @@ termConstructor source sourceSpan category range children allChildren
where
withDefaultInfo syntax =
pure $! case syntax of
S.MethodCall{} -> cofree ((range .: MethodCall .: sourceSpan .: RNil) :< syntax)
_ -> cofree ((range .: category .: sourceSpan .: RNil) :< syntax)
S.MethodCall{} -> cofree ((range :. MethodCall :. sourceSpan :. Nil) :< syntax)
_ -> cofree ((range :. category :. sourceSpan :. Nil) :< syntax)
categoryForJavaScriptProductionName :: Text -> Category
categoryForJavaScriptProductionName name = case name of

2
src/Language/Markdown.hs
View File

@ -19,7 +19,7 @@ cmarkParser SourceBlob{..} = pure . toTerm (totalRange source) (rangeToSourceSpa
range = maybe within (sourceSpanToRange source . toSpan) position
span = maybe withinSpan toSpan position
in
cofree $ (range .: toCategory t .: span .: RNil) :< case t of
cofree $ (range :. toCategory t :. span :. Nil) :< case t of
-- Leaves
CODE text -> Leaf text
TEXT text -> Leaf text

2
src/Language/Ruby.hs
View File

@ -124,7 +124,7 @@ termConstructor source sourceSpan category range children allChildren
where
withRecord record syntax = cofree (record :< syntax)
withCategory category syntax =
cofree ((range .: category .: sourceSpan .: RNil) :< syntax)
cofree ((range :. category :. sourceSpan :. Nil) :< syntax)
withDefaultInfo syntax = case syntax of
S.MethodCall{} -> withCategory MethodCall syntax
_ -> withCategory category syntax

6
src/Parse.hs
View File

@ -81,7 +81,7 @@ parserForType mediaType = case languageForType mediaType of
-- | Decorate a 'Term' using a function to compute the annotation values at every node.
decorateTerm :: (Functor f) => TermDecorator f fields field -> Term f (Record fields) -> Term f (Record (field ': fields))
decorateTerm decorator = cata $ \ term -> cofree ((decorator (extract <$> term) .: headF term) :< tailF term)
decorateTerm decorator = cata $ \ term -> cofree ((decorator (extract <$> term) :. headF term) :< tailF term)
-- | A function computing a value to decorate terms with. This can be used to cache synthesized attributes on terms.
type TermDecorator f fields field = TermF f (Record fields) (Record (field ': fields)) -> field
@ -101,8 +101,8 @@ lineByLineParser SourceBlob{..} = pure . cofree . root $ case foldl' annotateLea
(leaves, _) -> cofree <$> leaves
where
lines = actualLines source
root children = (Range 0 (length source) .: Program .: rangeToSourceSpan source (Range 0 (length source)) .: RNil) :< Indexed children
leaf charIndex line = (Range charIndex (charIndex + T.length line) .: Program .: rangeToSourceSpan source (Range charIndex (charIndex + T.length line)) .: RNil) :< Leaf line
root children = (Range 0 (length source) :. Program :. rangeToSourceSpan source (Range 0 (length source)) :. Nil) :< Indexed children
leaf charIndex line = (Range charIndex (charIndex + T.length line) :. Program :. rangeToSourceSpan source (Range charIndex (charIndex + T.length line)) :. Nil) :< Leaf line
annotateLeaves (accum, charIndex) line =
(accum <> [ leaf charIndex (toText line) ] , charIndex + length line)
toText = T.pack . Source.toString

2
src/Range.hs
View File

@ -38,7 +38,7 @@ rangesAndWordsFrom startIndex string = fromMaybe [] $ take isWord <|> take isPun
([], _) -> Nothing
(parsed, rest) -> Just . maybe identity (:) (transform parsed) $ rangesAndWordsFrom (endFor parsed) rest
-- | Is this a word character?
-- | Word characters are defined as in [Ruby’s `\p{Word}` syntax](http://ruby-doc.org/core-2.1.1/Regexp.html#class-Regexp-label-Character+Properties), i.e.:
-- | Word characters are defined as in [Ruby’s `\p{Word}` syntax](http://ruby-doc.org/core-2.1.1/Regexp.html#class-Regexp-label-Character+Properties), i.e:.
-- | > A member of one of the following Unicode general category _Letter_, _Mark_, _Number_, _Connector_Punctuation_
isWord c = Char.isLetter c || Char.isNumber c || Char.isMark c || Char.generalCategory c == Char.ConnectorPunctuation
isPunctuation c = not (Char.isSpace c || isWord c)

2
test/AlignmentSpec.hs
View File

@ -260,7 +260,7 @@ align :: Both (Source.Source Char) -> ConstructibleFree (Patch (Term (Syntax Str
align sources = PrettyDiff sources . fmap (fmap (getRange &&& identity)) . alignDiff sources . deconstruct
info :: Int -> Int -> Record '[Range]
info start end = Range start end .: RNil
info start end = Range start end :. Nil
prettyDiff :: Both (Source.Source Char) -> [Join These (ConstructibleFree (SplitPatch (Term (Syntax String) (Record '[Range]))) (Record '[Range]))] -> PrettyDiff (SplitDiff (Syntax String) (Record '[Range]))
prettyDiff sources = PrettyDiff sources . fmap (fmap ((getRange &&& identity) . deconstruct))

6
test/Data/RandomWalkSimilarity/Spec.hs
View File

@ -36,12 +36,12 @@ spec = parallel $ do
prop "produces correct diffs" $
\ (as, bs) -> let tas = decorate <$> (unListableF <$> as :: [SyntaxTerm String '[Category]])
tbs = decorate <$> (unListableF <$> bs :: [SyntaxTerm String '[Category]])
root = cofree . ((Program .: RNil) :<) . Indexed
diff = wrap (pure (Program .: RNil) :< Indexed (stripDiff <$> rws compare getLabel tas tbs)) in
root = cofree . ((Program :. Nil) :<) . Indexed
diff = wrap (pure (Program :. Nil) :< Indexed (stripDiff <$> rws compare getLabel 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 .: RNil) :< Indexed [ cofree ((StringLiteral .: RNil) :< Leaf ("a" :: Text)) ])), decorate (cofree ((StringLiteral .: RNil) :< Indexed [ cofree ((StringLiteral .: RNil) :< Leaf "b") ]))) in
let (a, b) = (decorate (cofree ((StringLiteral :. Nil) :< Indexed [ cofree ((StringLiteral :. Nil) :< Leaf ("a" :: Text)) ])), decorate (cofree ((StringLiteral :. Nil) :< Indexed [ cofree ((StringLiteral :. Nil) :< Leaf "b") ]))) in
fmap stripDiff (rws compare getLabel [ b ] [ a, b ]) `shouldBe` fmap stripDiff [ inserting a, copying b ]
where compare :: (HasField fields Category, Functor f, Eq (Cofree f Category)) => Term f (Record fields) -> Term f (Record fields) -> Maybe (Diff f (Record fields))

4
test/DiffSummarySpec.hs
View File

@ -27,10 +27,10 @@ sourceSpanBetween :: (Int, Int) -> (Int, Int) -> SourceSpan
sourceSpanBetween (s1, e1) (s2, e2) = SourceSpan (SourcePos s1 e1) (SourcePos s2 e2)
arrayInfo :: Record '[Category, Range, SourceSpan]
arrayInfo = ArrayLiteral .: Range 0 3 .: sourceSpanBetween (1, 1) (1, 5) .: RNil
arrayInfo = ArrayLiteral :. Range 0 3 :. sourceSpanBetween (1, 1) (1, 5) :. Nil
literalInfo :: Record '[Category, Range, SourceSpan]
literalInfo = StringLiteral .: Range 1 2 .: sourceSpanBetween (1, 2) (1, 4) .: RNil
literalInfo = StringLiteral :. Range 1 2 :. sourceSpanBetween (1, 2) (1, 4) :. Nil
testDiff :: Diff (Syntax Text) (Record '[Category, Range, SourceSpan])
testDiff = free $ Free (pure arrayInfo :< Indexed [ free $ Pure (Insert (cofree $ literalInfo :< Leaf "\"a\"")) ])

12
test/InterpreterSpec.hs
View File

@ -2,7 +2,7 @@
module InterpreterSpec where
import Category
import Data.Functor.Foldable
import Data.Functor.Foldable hiding (Nil)
import Data.Functor.Listable
import Data.RandomWalkSimilarity
import Data.Record
@ -25,8 +25,8 @@ spec = parallel $ do
let decorate = defaultFeatureVectorDecorator (category . headF)
let compare = (==) `on` category . extract
it "returns a replacement when comparing two unicode equivalent terms" $
let termA = cofree $ (StringLiteral .: RNil) :< Leaf ("t\776" :: String)
termB = cofree $ (StringLiteral .: RNil) :< Leaf "\7831" in
let termA = cofree $ (StringLiteral :. Nil) :< Leaf ("t\776" :: String)
termB = cofree $ (StringLiteral :. Nil) :< Leaf "\7831" in
stripDiff (diffTerms wrap compare diffCost getLabel (decorate termA) (decorate termB)) `shouldBe` replacing termA termB
prop "produces correct diffs" $
@ -39,6 +39,6 @@ spec = parallel $ do
diffCost diff `shouldBe` 0
it "produces unbiased insertions within branches" $
let term s = decorate (cofree ((StringLiteral .: RNil) :< Indexed [ cofree ((StringLiteral .: RNil) :< Leaf s) ]))
root = cofree . ((pure 0 .: Program .: RNil) :<) . Indexed in
stripDiff (diffTerms wrap compare diffCost getLabel (root [ term "b" ]) (root [ term "a", term "b" ])) `shouldBe` wrap (pure (Program .: RNil) :< Indexed [ inserting (stripTerm (term "a")), cata wrap (fmap pure (stripTerm (term "b"))) ])
let term s = decorate (cofree ((StringLiteral :. Nil) :< Indexed [ cofree ((StringLiteral :. Nil) :< Leaf s) ]))
root = cofree . ((pure 0 :. Program :. Nil) :<) . Indexed in
stripDiff (diffTerms wrap compare diffCost getLabel (root [ term "b" ]) (root [ term "a", term "b" ])) `shouldBe` wrap (pure (Program :. Nil) :< Indexed [ inserting (stripTerm (term "a")), cata wrap (fmap pure (stripTerm (term "b"))) ])

2
test/PatchOutputSpec.hs
View File

@ -14,4 +14,4 @@ spec :: Spec
spec = parallel $ do
describe "hunks" $ do
it "empty diffs have empty hunks" $
hunks (wrap $ pure (Range 0 0 .: RNil) :< Leaf ("" :: Text)) (both (SourceBlob (fromList "") "abcde" "path2.txt" (Just defaultPlainBlob)) (SourceBlob (fromList "") "xyz" "path2.txt" (Just defaultPlainBlob))) `shouldBe` [Hunk {offset = pure 0, changes = [], trailingContext = []}]
hunks (wrap $ pure (Range 0 0 :. Nil) :< Leaf ("" :: Text)) (both (SourceBlob (fromList "") "abcde" "path2.txt" (Just defaultPlainBlob)) (SourceBlob (fromList "") "xyz" "path2.txt" (Just defaultPlainBlob))) `shouldBe` [Hunk {offset = pure 0, changes = [], trailingContext = []}]