mirror of
https://github.com/github/semantic.git
synced 2024-11-24 08:54:07 +03:00
Generalize Term/TermF & Diff/DiffF over the functor.
This commit is contained in:
Rob Rix
parent
fe7854ad6e
commit
98637ad656
@ -38,15 +38,15 @@ numberedRows = countUp (both 1 1)
|
||||
nextLineNumbers from row = modifyJoin (fromThese identity identity) (succ <$ row) <*> from
|
||||
|
||||
-- | Determine whether a line contains any patches.
|
||||
hasChanges :: SplitDiff leaf annotation -> Bool
|
||||
hasChanges :: (Prologue.Foldable f, Functor f) => SplitDiff f annotation -> Bool
|
||||
hasChanges = or . (True <$)
|
||||
|
||||
-- | Align a Diff into a list of Join These SplitDiffs representing the (possibly blank) lines on either side.
|
||||
alignDiff :: HasField fields Range => Both (Source Char) -> Diff leaf (Record fields) -> [Join These (SplitDiff leaf (Record fields))]
|
||||
alignDiff :: HasField fields Range => Both (Source Char) -> Diff (Syntax leaf) (Record fields) -> [Join These (SplitDiff (Syntax leaf) (Record fields))]
|
||||
alignDiff sources diff = iter (alignSyntax (runBothWith ((Join .) . These)) wrap getRange sources) (alignPatch sources <$> diff)
|
||||
|
||||
-- | Align the contents of a patch into a list of lines on the corresponding side(s) of the diff.
|
||||
alignPatch :: forall fields leaf. HasField fields Range => Both (Source Char) -> Patch (Term leaf (Record fields)) -> [Join These (SplitDiff leaf (Record fields))]
|
||||
alignPatch :: forall fields leaf. HasField fields Range => Both (Source Char) -> Patch (Term (Syntax leaf) (Record fields)) -> [Join These (SplitDiff (Syntax leaf) (Record fields))]
|
||||
alignPatch sources patch = case patch of
|
||||
Delete term -> fmap (pure . SplitDelete) <$> alignSyntax' this (fst sources) term
|
||||
Insert term -> fmap (pure . SplitInsert) <$> alignSyntax' that (snd sources) term
|
||||
@ -54,13 +54,13 @@ alignPatch sources patch = case patch of
|
||||
(alignSyntax' this (fst sources) term1)
|
||||
(alignSyntax' that (snd sources) term2)
|
||||
where getRange = characterRange . extract
|
||||
alignSyntax' :: (forall a. Identity a -> Join These a) -> Source Char -> Term leaf (Record fields) -> [Join These (Term leaf (Record fields))]
|
||||
alignSyntax' :: (forall a. Identity a -> Join These a) -> Source Char -> Term (Syntax leaf) (Record fields) -> [Join These (Term (Syntax leaf) (Record fields))]
|
||||
alignSyntax' side source term = hylo (alignSyntax side cofree getRange (Identity source)) runCofree (Identity <$> term)
|
||||
this = Join . This . runIdentity
|
||||
that = Join . That . runIdentity
|
||||
|
||||
-- | The Applicative instance f is either Identity or Both. Identity is for Terms in Patches, Both is for Diffs in unchanged portions of the diff.
|
||||
alignSyntax :: (Applicative f, HasField fields Range) => (forall a. f a -> Join These a) -> (CofreeF (Syntax leaf) (Record fields) term -> term) -> (term -> Range) -> f (Source Char) -> CofreeF (Syntax leaf) (f (Record fields)) [Join These term] -> [Join These term]
|
||||
alignSyntax :: (Applicative f, HasField fields Range) => (forall a. f a -> Join These a) -> (TermF (Syntax leaf) (Record fields) term -> term) -> (term -> Range) -> f (Source Char) -> TermF (Syntax leaf) (f (Record fields)) [Join These term] -> [Join These term]
|
||||
alignSyntax toJoinThese toNode getRange sources (infos :< syntax) = catMaybes $ case syntax of
|
||||
Leaf s -> wrapInBranch (const (Leaf s)) <$> alignBranch getRange [] bothRanges
|
||||
Syntax.Comment a -> wrapInBranch (const (Syntax.Comment a)) <$> alignBranch getRange [] bothRanges
|
||||
|
||||
17
src/Diff.hs
17
src/Diff.hs
@ -7,34 +7,33 @@ import Data.Functor.Foldable as Foldable
|
||||
import Data.Functor.Both as Both
|
||||
import Data.Mergeable
|
||||
import Patch
|
||||
import Syntax
|
||||
import Term
|
||||
|
||||
-- | An annotated series of patches of terms.
|
||||
type DiffF leaf annotation = FreeF (CofreeF (Syntax leaf) (Both annotation)) (Patch (Term leaf annotation))
|
||||
type Diff a annotation = Free (CofreeF (Syntax a) (Both annotation)) (Patch (Term a 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 instance Base (Free f a) = FreeF f a
|
||||
instance Functor f => Foldable.Foldable (Free f a) where project = runFree
|
||||
instance Functor f => Foldable.Unfoldable (Free f a) where embed = free
|
||||
|
||||
diffSum :: (Patch (Term a annotation) -> Int) -> Diff a annotation -> Int
|
||||
diffSum :: (Prologue.Foldable f, Functor f) => (Patch (Term f annotation) -> Int) -> Diff f annotation -> Int
|
||||
diffSum patchCost diff = sum $ fmap patchCost diff
|
||||
|
||||
-- | The sum of the node count of the diff’s patches.
|
||||
diffCost :: Diff a annotation -> Int
|
||||
diffCost :: (Prologue.Foldable f, Functor f) => Diff f annotation -> Int
|
||||
diffCost = diffSum $ patchSum termSize
|
||||
|
||||
-- | Merge a diff using a function to provide the Term (in Maybe, to simplify recovery of the before/after state) for every Patch.
|
||||
mergeMaybe :: (Patch (Term leaf annotation) -> Maybe (Term leaf annotation)) -> Diff leaf annotation -> Maybe (Term leaf annotation)
|
||||
mergeMaybe :: (Functor f, Mergeable f) => (Patch (Term f annotation) -> Maybe (Term f annotation)) -> Diff f annotation -> Maybe (Term f annotation)
|
||||
mergeMaybe transform = iter algebra . fmap transform
|
||||
where algebra :: CofreeF (Syntax leaf) (Both annotation) (Maybe (Term leaf annotation)) -> Maybe (Term leaf annotation)
|
||||
where algebra :: Mergeable f => TermF f (Both annotation) (Maybe (Term f annotation)) -> Maybe (Term f annotation)
|
||||
algebra (annotations :< syntax) = cofree . (Both.fst annotations :<) <$> sequenceAlt syntax
|
||||
|
||||
-- | Recover the before state of a diff.
|
||||
beforeTerm :: Diff leaf annotation -> Maybe (Term leaf annotation)
|
||||
beforeTerm :: (Functor f, Mergeable f) => Diff f annotation -> Maybe (Term f annotation)
|
||||
beforeTerm = mergeMaybe before
|
||||
|
||||
-- | Recover the after state of a diff.
|
||||
afterTerm :: Diff leaf annotation -> Maybe (Term leaf annotation)
|
||||
afterTerm :: (Functor f, Mergeable f) => Diff f annotation -> Maybe (Term f annotation)
|
||||
afterTerm = mergeMaybe after
|
||||
|
||||
@ -3,11 +3,13 @@ module Diff.Arbitrary where
|
||||
import Diff
|
||||
import Data.Bifunctor.Join
|
||||
import Data.Bifunctor.Join.Arbitrary ()
|
||||
import Data.Functor.Both
|
||||
import Data.Functor.Foldable (unfold)
|
||||
import Patch
|
||||
import Patch.Arbitrary ()
|
||||
import Syntax
|
||||
import Prologue
|
||||
import Term
|
||||
import Term.Arbitrary
|
||||
import Test.QuickCheck hiding (Fixed)
|
||||
|
||||
@ -16,11 +18,11 @@ data ArbitraryDiff leaf annotation
|
||||
| ArbitraryPure (Patch (ArbitraryTerm leaf annotation))
|
||||
deriving (Show, Eq, Generic)
|
||||
|
||||
unArbitraryDiff :: ArbitraryDiff leaf annotation -> FreeF (CofreeF (Syntax leaf) (Join (,) annotation)) (Patch (ArbitraryTerm leaf annotation)) (ArbitraryDiff leaf annotation)
|
||||
unArbitraryDiff :: ArbitraryDiff leaf annotation -> FreeF (TermF (Syntax leaf) (Both annotation)) (Patch (ArbitraryTerm leaf annotation)) (ArbitraryDiff leaf annotation)
|
||||
unArbitraryDiff (ArbitraryFree a s) = Free (a :< s)
|
||||
unArbitraryDiff (ArbitraryPure p) = Pure p
|
||||
|
||||
toDiff :: ArbitraryDiff leaf annotation -> Diff leaf annotation
|
||||
toDiff :: ArbitraryDiff leaf annotation -> Diff (Syntax leaf) annotation
|
||||
toDiff = fmap (fmap toTerm) . unfold unArbitraryDiff
|
||||
|
||||
diffOfSize :: (Arbitrary leaf, Arbitrary annotation) => Int -> Gen (ArbitraryDiff leaf annotation)
|
||||
|
||||
@ -24,7 +24,7 @@ import Source
|
||||
|
||||
data Identifiable a = Identifiable a | Unidentifiable a
|
||||
|
||||
isIdentifiable :: (HasCategory leaf, HasField fields Category, HasField fields Range) => Term leaf (Record fields) -> Bool
|
||||
isIdentifiable :: (HasCategory leaf, HasField fields Category, HasField fields Range) => Term (Syntax leaf) (Record fields) -> Bool
|
||||
isIdentifiable term =
|
||||
case unwrap term of
|
||||
S.FunctionCall _ _ -> True
|
||||
@ -38,7 +38,7 @@ isIdentifiable term =
|
||||
S.Leaf _ -> True
|
||||
_ -> False
|
||||
|
||||
identifiable :: (HasCategory leaf, HasField fields Category, HasField fields Range) => Term leaf (Record fields) -> Identifiable (Term leaf (Record fields))
|
||||
identifiable :: (HasCategory leaf, HasField fields Category, HasField fields Range) => Term (Syntax leaf) (Record fields) -> Identifiable (Term (Syntax leaf) (Record fields))
|
||||
identifiable term = if isIdentifiable term then Identifiable term else Unidentifiable term
|
||||
|
||||
data DiffInfo = LeafInfo { categoryName :: Text, termName :: Text }
|
||||
@ -54,7 +54,7 @@ data DiffSummary a = DiffSummary {
|
||||
} deriving (Eq, Functor, Show, Generic)
|
||||
|
||||
-- Returns a list of diff summary texts given two source blobs and a diff.
|
||||
diffSummaries :: (HasCategory leaf, HasField fields Category, HasField fields Range) => Both SourceBlob -> Diff leaf (Record fields) -> [Either Text Text]
|
||||
diffSummaries :: (HasCategory leaf, HasField fields Category, HasField fields Range) => Both SourceBlob -> Diff (Syntax leaf) (Record fields) -> [Either Text Text]
|
||||
diffSummaries blobs diff = summaryToTexts =<< diffToDiffSummaries (source <$> blobs) diff
|
||||
|
||||
-- Takes a 'DiffSummary' and returns a list of summary texts representing the LeafInfos
|
||||
@ -63,7 +63,7 @@ summaryToTexts :: DiffSummary DiffInfo -> [Either Text Text]
|
||||
summaryToTexts DiffSummary{..} = runJoin . fmap (show . (P.<> maybeParentContext parentAnnotation)) <$> (Join <$> summaries patch)
|
||||
|
||||
-- Returns a list of 'DiffSummary' given two source blobs and a diff.
|
||||
diffToDiffSummaries :: (HasCategory leaf, HasField fields Category, HasField fields Range) => Both (Source Char) -> Diff leaf (Record fields) -> [DiffSummary DiffInfo]
|
||||
diffToDiffSummaries :: (HasCategory leaf, HasField fields Category, HasField fields Range) => Both (Source Char) -> Diff (Syntax leaf) (Record fields) -> [DiffSummary DiffInfo]
|
||||
diffToDiffSummaries sources = para $ \diff ->
|
||||
let diff' = free (Prologue.fst <$> diff)
|
||||
annotateWithCategory :: [(Diff leaf (Record fields), [DiffSummary DiffInfo])] -> [DiffSummary DiffInfo]
|
||||
@ -104,7 +104,7 @@ toLeafInfos BranchInfo{..} = toLeafInfos =<< branches
|
||||
toLeafInfos err@ErrorInfo{} = pure (pretty err)
|
||||
|
||||
-- Returns a text representing a specific term given a source and a term.
|
||||
toTermName :: forall leaf fields. (HasCategory leaf, HasField fields Category, HasField fields Range) => Source Char -> Term leaf (Record fields) -> Text
|
||||
toTermName :: forall leaf fields. (HasCategory leaf, HasField fields Category, HasField fields Range) => Source Char -> Term (Syntax leaf) (Record fields) -> Text
|
||||
toTermName source term = case unwrap term of
|
||||
S.AnonymousFunction _ _ -> "anonymous"
|
||||
S.Fixed children -> fromMaybe "branch" $ (toCategoryName . category) . extract <$> head children
|
||||
@ -162,7 +162,7 @@ toTermName source term = case unwrap term of
|
||||
termNameFromSource term = termNameFromRange (range term)
|
||||
termNameFromRange range = toText $ Source.slice range source
|
||||
range = characterRange . extract
|
||||
toArgName :: (HasCategory leaf, HasField fields Category, HasField fields Range) => Term leaf (Record fields) -> Text
|
||||
toArgName :: (HasCategory leaf, HasField fields Category, HasField fields Range) => Term (Syntax leaf) (Record fields) -> Text
|
||||
toArgName arg = case identifiable arg of
|
||||
Identifiable arg -> toTermName' arg
|
||||
Unidentifiable _ -> "..."
|
||||
@ -174,7 +174,7 @@ maybeParentContext = maybe "" (\annotation ->
|
||||
toDoc :: Text -> Doc
|
||||
toDoc = string . toS
|
||||
|
||||
termToDiffInfo :: (HasCategory leaf, HasField fields Category, HasField fields Range) => Source Char -> Term leaf (Record fields) -> DiffInfo
|
||||
termToDiffInfo :: (HasCategory leaf, HasField fields Category, HasField fields Range) => Source Char -> Term (Syntax leaf) (Record fields) -> DiffInfo
|
||||
termToDiffInfo blob term = case unwrap term of
|
||||
Leaf _ -> LeafInfo (toCategoryName term) (toTermName' term)
|
||||
S.AnonymousFunction _ _ -> LeafInfo (toCategoryName term) ("anonymous")
|
||||
@ -193,7 +193,7 @@ termToDiffInfo blob term = case unwrap term of
|
||||
where toTermName' = toTermName blob
|
||||
termToDiffInfo' = termToDiffInfo blob
|
||||
|
||||
prependSummary :: (HasCategory leaf, HasField fields Range, HasField fields Category) => Source Char -> Term leaf (Record fields) -> DiffSummary DiffInfo -> DiffSummary DiffInfo
|
||||
prependSummary :: (HasCategory leaf, HasField fields Range, HasField fields Category) => Source Char -> Term (Syntax leaf) (Record fields) -> DiffSummary DiffInfo -> DiffSummary DiffInfo
|
||||
prependSummary source term summary =
|
||||
case (parentAnnotation summary, identifiable term) of
|
||||
(Nothing, Identifiable term) -> summary { parentAnnotation = Just (category . extract $ term, toTermName source term) }
|
||||
@ -270,7 +270,7 @@ instance HasCategory Category where
|
||||
C.CommaOperator -> "comma operator"
|
||||
C.Empty -> "empty statement"
|
||||
|
||||
instance (HasCategory leaf, HasField fields Category) => HasCategory (Term leaf (Record fields)) where
|
||||
instance (HasCategory leaf, HasField fields Category) => HasCategory (Term (Syntax leaf) (Record fields)) where
|
||||
toCategoryName = toCategoryName . category . extract
|
||||
|
||||
instance Arbitrary Branch where
|
||||
|
||||
@ -93,7 +93,7 @@ parserForFilepath path blob = decorateTerm termCostDecorator <$> do
|
||||
pure $! breakDownLeavesByWord (source blob) parsed
|
||||
|
||||
-- | Replace every string leaf with leaves of the words in the string.
|
||||
breakDownLeavesByWord :: (HasField fields Category, HasField fields Range) => Source Char -> Term Text (Record fields) -> Term Text (Record fields)
|
||||
breakDownLeavesByWord :: (HasField fields Category, HasField fields Range) => Source Char -> Term (Syntax Text) (Record fields) -> Term (Syntax Text) (Record fields)
|
||||
breakDownLeavesByWord source = cata replaceIn
|
||||
where
|
||||
replaceIn (info :< syntax) = cofree $ info :< syntax'
|
||||
@ -133,11 +133,11 @@ termCostDecorator :: (Prologue.Foldable f, Functor f) => TermDecorator f a Cost
|
||||
termCostDecorator c = 1 + sum (cost <$> tailF c)
|
||||
|
||||
-- | Determine whether two terms are comparable based on the equality of their categories.
|
||||
compareCategoryEq :: HasField fields Category => Term leaf (Record fields) -> Term leaf (Record fields) -> Bool
|
||||
compareCategoryEq :: Functor f => HasField fields Category => Term f (Record fields) -> Term f (Record fields) -> Bool
|
||||
compareCategoryEq = (==) `on` category . extract
|
||||
|
||||
-- | The sum of the node count of the diff’s patches.
|
||||
diffCostWithCachedTermCosts :: HasField fields Cost => Diff leaf (Record fields) -> Int
|
||||
diffCostWithCachedTermCosts :: Functor f => HasField fields Cost => Diff f (Record fields) -> Int
|
||||
diffCostWithCachedTermCosts diff = unCost $ case runFree diff of
|
||||
Free (info :< _) -> sum (cost <$> info)
|
||||
Pure patch -> sum (cost . extract <$> patch)
|
||||
|
||||
@ -19,23 +19,23 @@ import Syntax as S
|
||||
import Term
|
||||
|
||||
-- | Returns whether two terms are comparable
|
||||
type Comparable leaf annotation = Term leaf annotation -> Term leaf annotation -> Bool
|
||||
type Comparable f annotation = Term f annotation -> Term f annotation -> Bool
|
||||
|
||||
-- | Constructs a diff from the CofreeF containing its annotation and syntax. This function has the opportunity to, for example, cache properties in the annotation.
|
||||
type DiffConstructor leaf annotation = CofreeF (Syntax leaf) (Both annotation) (Diff leaf annotation) -> Diff leaf annotation
|
||||
type DiffConstructor f annotation = TermF f (Both annotation) (Diff f annotation) -> Diff f annotation
|
||||
|
||||
-- | Diff two terms recursively, given functions characterizing the diffing.
|
||||
diffTerms :: (Eq leaf, Eq (Record fields), HasField fields Category, HasField fields (Vector.Vector Double))
|
||||
=> DiffConstructor leaf (Record fields) -- ^ A function to wrap up & possibly annotate every produced diff.
|
||||
-> Comparable leaf (Record fields) -- ^ A function to determine whether or not two terms should even be compared.
|
||||
-> SES.Cost (Diff leaf (Record fields)) -- ^ A function to compute the cost of a given diff node.
|
||||
-> Term leaf (Record fields) -- ^ A term representing the old state.
|
||||
-> Term leaf (Record fields) -- ^ A term representing the new state.
|
||||
-> Diff leaf (Record fields)
|
||||
=> DiffConstructor (Syntax leaf) (Record fields) -- ^ A function to wrap up & possibly annotate every produced diff.
|
||||
-> Comparable (Syntax leaf) (Record fields) -- ^ A function to determine whether or not two terms should even be compared.
|
||||
-> SES.Cost (Diff (Syntax leaf) (Record fields)) -- ^ A function to compute the cost of a given diff node.
|
||||
-> Term (Syntax leaf) (Record fields) -- ^ A term representing the old state.
|
||||
-> Term (Syntax leaf) (Record fields) -- ^ A term representing the new state.
|
||||
-> Diff (Syntax leaf) (Record fields)
|
||||
diffTerms construct comparable cost a b = fromMaybe (replacing a b) $ diffComparableTerms construct comparable cost a b
|
||||
|
||||
-- | Diff two terms recursively, given functions characterizing the diffing. If the terms are incomparable, returns 'Nothing'.
|
||||
diffComparableTerms :: (Eq leaf, Eq (Record fields), HasField fields Category, HasField fields (Vector.Vector Double)) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Maybe (Diff leaf (Record fields))
|
||||
diffComparableTerms :: (Eq leaf, Eq (Record fields), HasField fields Category, HasField fields (Vector.Vector Double)) => DiffConstructor (Syntax leaf) (Record fields) -> Comparable (Syntax leaf) (Record fields) -> SES.Cost (Diff (Syntax leaf) (Record fields)) -> Term (Syntax leaf) (Record fields) -> Term (Syntax leaf) (Record fields) -> Maybe (Diff (Syntax leaf) (Record fields))
|
||||
diffComparableTerms construct comparable cost = recur
|
||||
where recur a b
|
||||
| (category <$> a) == (category <$> b) = hylo construct runCofree <$> zipTerms a b
|
||||
@ -43,7 +43,7 @@ diffComparableTerms construct comparable cost = recur
|
||||
| otherwise = Nothing
|
||||
|
||||
-- | Construct an algorithm to diff a pair of terms.
|
||||
algorithmWithTerms :: (TermF leaf (Both a) diff -> diff) -> Term leaf a -> Term leaf a -> Algorithm (Term leaf a) diff diff
|
||||
algorithmWithTerms :: (TermF (Syntax leaf) (Both a) diff -> diff) -> Term (Syntax leaf) a -> Term (Syntax leaf) a -> Algorithm (Term (Syntax leaf) a) diff diff
|
||||
algorithmWithTerms construct t1 t2 = case (unwrap t1, unwrap t2) of
|
||||
(Indexed a, Indexed b) -> branch Indexed a b
|
||||
(S.FunctionCall identifierA argsA, S.FunctionCall identifierB argsB) -> do
|
||||
|
||||
@ -43,8 +43,8 @@ termConstructor
|
||||
-> IO SourceSpan -- ^ The span that the term occupies. This is passed in 'IO' to guarantee some access constraints & encourage its use only when needed (improving performance).
|
||||
-> Text -- ^ The name of the production for this node.
|
||||
-> Range -- ^ The character range that the term occupies.
|
||||
-> [Term Text (Record '[Range, Category])] -- ^ The child nodes of the term.
|
||||
-> IO (Term Text (Record '[Range, Category])) -- ^ The resulting term, in IO.
|
||||
-> [Term (S.Syntax Text) (Record '[Range, Category])] -- ^ The child nodes of the term.
|
||||
-> IO (Term (S.Syntax Text) (Record '[Range, Category])) -- ^ The resulting term, in IO.
|
||||
termConstructor source sourceSpan name range children =
|
||||
withDefaultInfo <$> case (name, children) of
|
||||
("ERROR", _) -> S.Error <$> sourceSpan <*> pure children
|
||||
|
||||
@ -6,6 +6,7 @@ import Info
|
||||
import Prologue
|
||||
import Source
|
||||
import SourceSpan
|
||||
import Syntax
|
||||
import qualified Syntax as S
|
||||
import Term
|
||||
|
||||
@ -14,8 +15,8 @@ termConstructor
|
||||
-> IO SourceSpan -- ^ The span that the term occupies. This is passed in 'IO' to guarantee some access constraints & encourage its use only when needed (improving performance).
|
||||
-> Text -- ^ The name of the production for this node.
|
||||
-> Range -- ^ The character range that the term occupies.
|
||||
-> [Term Text (Record '[Range, Category])] -- ^ The child nodes of the term.
|
||||
-> IO (Term Text (Record '[Range, Category])) -- ^ The resulting term, in IO.
|
||||
-> [Term (Syntax Text) (Record '[Range, Category])] -- ^ The child nodes of the term.
|
||||
-> IO (Term (Syntax Text) (Record '[Range, Category])) -- ^ The resulting term, in IO.
|
||||
termConstructor source sourceSpan name range children
|
||||
| name == "ERROR" = sourceSpan >>= withDefaultInfo . (`S.Error` children)
|
||||
| otherwise = withDefaultInfo $ case (name, children) of
|
||||
|
||||
@ -14,8 +14,8 @@ termConstructor
|
||||
-> IO SourceSpan -- ^ The span that the term occupies. This is passed in 'IO' to guarantee some access constraints & encourage its use only when needed (improving performance).
|
||||
-> Text -- ^ The name of the production for this node.
|
||||
-> Range -- ^ The character range that the term occupies.
|
||||
-> [Term Text (Record '[Range, Category])] -- ^ The child nodes of the term.
|
||||
-> IO (Term Text (Record '[Range, Category])) -- ^ The resulting term, in IO.
|
||||
-> [Term (S.Syntax Text) (Record '[Range, Category])] -- ^ The child nodes of the term.
|
||||
-> IO (Term (S.Syntax Text) (Record '[Range, Category])) -- ^ The resulting term, in IO.
|
||||
termConstructor source sourceSpan name range children
|
||||
| name == "ERROR" = sourceSpan >>= withDefaultInfo . (`S.Error` children)
|
||||
| otherwise = withDefaultInfo $ case (name, children) of
|
||||
@ -136,10 +136,10 @@ categoryForJavaScriptProductionName name = case name of
|
||||
"rel_op" -> RelationalOperator
|
||||
_ -> Other name
|
||||
|
||||
toVarDecl :: (HasField fields Category) => Term Text (Record fields) -> Term Text (Record fields)
|
||||
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)
|
||||
|
||||
toTuple :: Term Text (Record fields) -> [Term Text (Record fields)]
|
||||
toTuple :: Term (S.Syntax Text) (Record fields) -> [Term (S.Syntax Text) (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)]
|
||||
|
||||
@ -1,16 +1,17 @@
|
||||
module Renderer (Renderer, DiffArguments(..), Output(..), concatOutputs, toSummaryKey, Format(..)) where
|
||||
|
||||
import Prologue
|
||||
import Data.Functor.Both
|
||||
import Diff
|
||||
import Source (SourceBlob)
|
||||
import Data.Text as T (intercalate)
|
||||
import Data.Aeson (Value, toEncoding)
|
||||
import Data.Aeson.Encoding (encodingToLazyByteString)
|
||||
import Data.Functor.Both
|
||||
import Data.Map as Map hiding (null)
|
||||
import Data.Text as T (intercalate)
|
||||
import Diff
|
||||
import Prologue
|
||||
import Source (SourceBlob)
|
||||
import Syntax
|
||||
|
||||
-- | A function that will render a diff, given the two source blobs.
|
||||
type Renderer annotation = Both SourceBlob -> Diff Text annotation -> Output
|
||||
type Renderer annotation = Both SourceBlob -> Diff (Syntax Text) annotation -> Output
|
||||
|
||||
data DiffArguments = DiffArguments { format :: Format, output :: Maybe FilePath, outputPath :: FilePath }
|
||||
deriving (Show)
|
||||
|
||||
@ -32,7 +32,7 @@ json blobs diff = JSONOutput $ Map.fromList [
|
||||
-- | A numbered 'a'.
|
||||
newtype NumberedLine a = NumberedLine (Int, a)
|
||||
|
||||
instance (HasField fields Category, HasField fields Range) => ToJSON (NumberedLine (SplitDiff leaf (Record fields))) where
|
||||
instance (HasField fields Category, HasField fields Range) => ToJSON (NumberedLine (SplitDiff (Syntax leaf) (Record fields))) where
|
||||
toJSON (NumberedLine (n, a)) = object (lineFields n a (getRange a))
|
||||
toEncoding (NumberedLine (n, a)) = pairs $ mconcat (lineFields n a (getRange a))
|
||||
instance ToJSON Category where
|
||||
@ -46,18 +46,18 @@ instance ToJSON a => ToJSON (Join These a) where
|
||||
toEncoding = foldable
|
||||
instance ToJSON a => ToJSON (Join (,) a) where
|
||||
toJSON (Join (a, b)) = A.Array . Vector.fromList $ toJSON <$> [ a, b ]
|
||||
instance (HasField fields Category, HasField fields Range) => ToJSON (SplitDiff leaf (Record fields)) where
|
||||
instance (HasField fields Category, HasField fields Range) => ToJSON (SplitDiff (Syntax leaf) (Record fields)) where
|
||||
toJSON splitDiff = case runFree splitDiff of
|
||||
(Free (info :< syntax)) -> object (termFields info syntax)
|
||||
(Pure patch) -> object (patchFields patch)
|
||||
toEncoding splitDiff = case runFree splitDiff of
|
||||
(Free (info :< syntax)) -> pairs $ mconcat (termFields info syntax)
|
||||
(Pure patch) -> pairs $ mconcat (patchFields patch)
|
||||
instance (HasField fields Category, HasField fields Range) => ToJSON (Term leaf (Record fields)) where
|
||||
instance (HasField fields Category, HasField fields Range) => ToJSON (Term (Syntax leaf) (Record fields)) where
|
||||
toJSON term | (info :< syntax) <- runCofree term = object (termFields info syntax)
|
||||
toEncoding term | (info :< syntax) <- runCofree term = pairs $ mconcat (termFields info syntax)
|
||||
|
||||
lineFields :: (HasField fields Category, HasField fields Range) => KeyValue kv => Int -> SplitDiff leaf (Record fields) -> Range -> [kv]
|
||||
lineFields :: (HasField fields Category, HasField fields Range) => KeyValue kv => Int -> SplitDiff (Syntax leaf) (Record fields) -> Range -> [kv]
|
||||
lineFields n term range = [ "number" .= n
|
||||
, "terms" .= [ term ]
|
||||
, "range" .= range
|
||||
@ -102,7 +102,7 @@ termFields info syntax = "range" .= characterRange info : "category" .= category
|
||||
S.Method identifier params definitions -> [ "methodIdentifier" .= identifier ] <> [ "params" .= params ] <> [ "definitions" .= definitions ]
|
||||
where childrenFields c = [ "children" .= c ]
|
||||
|
||||
patchFields :: (KeyValue kv, HasField fields Category, HasField fields Range) => SplitPatch (Term leaf (Record fields)) -> [kv]
|
||||
patchFields :: (KeyValue kv, HasField fields Category, HasField fields Range) => SplitPatch (Term (Syntax leaf) (Record fields)) -> [kv]
|
||||
patchFields patch = case patch of
|
||||
SplitInsert term -> fields "insert" term
|
||||
SplitDelete term -> fields "delete" term
|
||||
|
||||
@ -20,6 +20,7 @@ import Range
|
||||
import Renderer
|
||||
import Source hiding (break)
|
||||
import SplitDiff
|
||||
import Syntax
|
||||
|
||||
-- | Render a timed out file as a truncated diff.
|
||||
truncatePatch :: DiffArguments -> Both SourceBlob -> Text
|
||||
@ -53,7 +54,7 @@ rowIncrement :: Join These a -> Both (Sum Int)
|
||||
rowIncrement = Join . fromThese (Sum 0) (Sum 0) . runJoin . (Sum 1 <$)
|
||||
|
||||
-- | Given the before and after sources, render a hunk to a string.
|
||||
showHunk :: HasField fields Range => Both SourceBlob -> Hunk (SplitDiff a (Record fields)) -> String
|
||||
showHunk :: Functor f => HasField fields Range => Both SourceBlob -> Hunk (SplitDiff f (Record fields)) -> String
|
||||
showHunk blobs hunk = maybeOffsetHeader <>
|
||||
concat (showChange sources <$> changes hunk) <>
|
||||
showLines (snd sources) ' ' (maybeSnd . runJoin <$> trailingContext hunk)
|
||||
@ -66,18 +67,18 @@ showHunk blobs hunk = maybeOffsetHeader <>
|
||||
(offsetA, offsetB) = runJoin . fmap (show . getSum) $ offset hunk
|
||||
|
||||
-- | Given the before and after sources, render a change to a string.
|
||||
showChange :: HasField fields Range => Both (Source Char) -> Change (SplitDiff a (Record fields)) -> String
|
||||
showChange :: Functor f => HasField fields Range => Both (Source Char) -> Change (SplitDiff f (Record fields)) -> String
|
||||
showChange sources change = showLines (snd sources) ' ' (maybeSnd . runJoin <$> context change) <> deleted <> inserted
|
||||
where (deleted, inserted) = runJoin $ pure showLines <*> sources <*> both '-' '+' <*> Join (unzip (fromThese Nothing Nothing . runJoin . fmap Just <$> contents change))
|
||||
|
||||
-- | Given a source, render a set of lines to a string with a prefix.
|
||||
showLines :: HasField fields Range => Source Char -> Char -> [Maybe (SplitDiff leaf (Record fields))] -> String
|
||||
showLines :: Functor f => HasField fields Range => Source Char -> Char -> [Maybe (SplitDiff f (Record fields))] -> String
|
||||
showLines source prefix lines = fromMaybe "" . mconcat $ fmap prepend . showLine source <$> lines
|
||||
where prepend "" = ""
|
||||
prepend source = prefix : source
|
||||
|
||||
-- | Given a source, render a line to a string.
|
||||
showLine :: HasField fields Range => Source Char -> Maybe (SplitDiff leaf (Record fields)) -> Maybe String
|
||||
showLine :: Functor f => HasField fields Range => Source Char -> Maybe (SplitDiff f (Record fields)) -> Maybe String
|
||||
showLine source line | Just line <- line = Just . toString . (`slice` source) $ getRange line
|
||||
| otherwise = Nothing
|
||||
|
||||
@ -116,7 +117,7 @@ emptyHunk :: Hunk (SplitDiff a annotation)
|
||||
emptyHunk = Hunk { offset = mempty, changes = [], trailingContext = [] }
|
||||
|
||||
-- | Render a diff as a series of hunks.
|
||||
hunks :: HasField fields Range => Diff a (Record fields) -> Both SourceBlob -> [Hunk (SplitDiff a (Record fields))]
|
||||
hunks :: HasField fields Range => Diff (Syntax leaf) (Record fields) -> Both SourceBlob -> [Hunk (SplitDiff (Syntax leaf) (Record fields))]
|
||||
hunks _ blobs | sources <- source <$> blobs
|
||||
, sourcesEqual <- runBothWith (==) sources
|
||||
, sourcesNull <- runBothWith (&&) (null <$> sources)
|
||||
@ -126,14 +127,14 @@ hunks diff blobs = hunksInRows (pure 1) $ alignDiff (source <$> blobs) diff
|
||||
|
||||
-- | Given beginning line numbers, turn rows in a split diff into hunks in a
|
||||
-- | patch.
|
||||
hunksInRows :: Both (Sum Int) -> [Join These (SplitDiff a annotation)] -> [Hunk (SplitDiff a annotation)]
|
||||
hunksInRows :: (Prologue.Foldable f, Functor f) => Both (Sum Int) -> [Join These (SplitDiff f annotation)] -> [Hunk (SplitDiff f annotation)]
|
||||
hunksInRows start rows = case nextHunk start rows of
|
||||
Nothing -> []
|
||||
Just (hunk, rest) -> hunk : hunksInRows (offset hunk <> hunkLength hunk) rest
|
||||
|
||||
-- | Given beginning line numbers, return the next hunk and the remaining rows
|
||||
-- | of the split diff.
|
||||
nextHunk :: Both (Sum Int) -> [Join These (SplitDiff a annotation)] -> Maybe (Hunk (SplitDiff a annotation), [Join These (SplitDiff a annotation)])
|
||||
nextHunk :: (Prologue.Foldable f, Functor f) => Both (Sum Int) -> [Join These (SplitDiff f annotation)] -> Maybe (Hunk (SplitDiff f annotation), [Join These (SplitDiff f annotation)])
|
||||
nextHunk start rows = case nextChange start rows of
|
||||
Nothing -> Nothing
|
||||
Just (offset, change, rest) -> let (changes, rest') = contiguousChanges rest in Just (Hunk offset (change : changes) $ take 3 rest', drop 3 rest')
|
||||
@ -145,7 +146,7 @@ nextHunk start rows = case nextChange start rows of
|
||||
|
||||
-- | Given beginning line numbers, return the number of lines to the next
|
||||
-- | the next change, and the remaining rows of the split diff.
|
||||
nextChange :: Both (Sum Int) -> [Join These (SplitDiff a annotation)] -> Maybe (Both (Sum Int), Change (SplitDiff a annotation), [Join These (SplitDiff a annotation)])
|
||||
nextChange :: (Prologue.Foldable f, Functor f) => Both (Sum Int) -> [Join These (SplitDiff f annotation)] -> Maybe (Both (Sum Int), Change (SplitDiff f annotation), [Join These (SplitDiff f annotation)])
|
||||
nextChange start rows = case changeIncludingContext leadingContext afterLeadingContext of
|
||||
Nothing -> Nothing
|
||||
Just (change, afterChanges) -> Just (start <> mconcat (rowIncrement <$> skippedContext), change, afterChanges)
|
||||
@ -155,12 +156,12 @@ nextChange start rows = case changeIncludingContext leadingContext afterLeadingC
|
||||
-- | Return a Change with the given context and the rows from the begginning of
|
||||
-- | the given rows that have changes, or Nothing if the first row has no
|
||||
-- | changes.
|
||||
changeIncludingContext :: [Join These (SplitDiff a annotation)] -> [Join These (SplitDiff a annotation)] -> Maybe (Change (SplitDiff a annotation), [Join These (SplitDiff a annotation)])
|
||||
changeIncludingContext :: (Prologue.Foldable f, Functor f) => [Join These (SplitDiff f annotation)] -> [Join These (SplitDiff f annotation)] -> Maybe (Change (SplitDiff f annotation), [Join These (SplitDiff f annotation)])
|
||||
changeIncludingContext leadingContext rows = case changes of
|
||||
[] -> Nothing
|
||||
_ -> Just (Change leadingContext changes, afterChanges)
|
||||
where (changes, afterChanges) = span rowHasChanges rows
|
||||
|
||||
-- | Whether a row has changes on either side.
|
||||
rowHasChanges :: Join These (SplitDiff a annotation) -> Bool
|
||||
rowHasChanges :: (Prologue.Foldable f, Functor f) => Join These (SplitDiff f annotation) -> Bool
|
||||
rowHasChanges row = or (hasChanges <$> row)
|
||||
|
||||
@ -147,10 +147,10 @@ instance (ToMarkup f, HasField fields Category, HasField fields Cost, HasField f
|
||||
Leaf _ -> span . string . toString $ slice (characterRange info) source
|
||||
_ -> ul . mconcat $ wrapIn li <$> contentElements source (characterRange info) (toList syntax)
|
||||
|
||||
instance (HasField fields Category, HasField fields Cost, HasField fields Range) => ToMarkup (Renderable (Term leaf (Record fields))) where
|
||||
instance (HasField fields Category, HasField fields Cost, HasField fields Range) => ToMarkup (Renderable (Term (Syntax leaf) (Record fields))) where
|
||||
toMarkup (Renderable source term) = Prologue.fst $ cata (\ t -> (toMarkup $ Renderable source t, characterRange (headF t))) term
|
||||
|
||||
instance (HasField fields Category, HasField fields Cost, HasField fields Range) => ToMarkup (Renderable (SplitDiff leaf (Record fields))) where
|
||||
instance (HasField fields Category, HasField fields Cost, HasField fields Range) => ToMarkup (Renderable (SplitDiff (Syntax leaf) (Record fields))) where
|
||||
toMarkup (Renderable source diff) = Prologue.fst . iter (\ t -> (toMarkup $ Renderable source t, characterRange (headF t))) $ toMarkupAndRange <$> diff
|
||||
where toMarkupAndRange patch = let term@(info :< _) = runCofree $ getSplitTerm patch in
|
||||
((div ! patchAttribute patch `withCostAttribute` cost info) . toMarkup $ Renderable source (cofree term), characterRange info)
|
||||
|
||||
@ -3,8 +3,7 @@ module SplitDiff where
|
||||
import Data.Record
|
||||
import Info
|
||||
import Prologue
|
||||
import Syntax
|
||||
import Term (Term)
|
||||
import Term (Term, TermF)
|
||||
|
||||
-- | A patch to only one side of a diff.
|
||||
data SplitPatch a = SplitInsert a | SplitDelete a | SplitReplace a
|
||||
@ -17,10 +16,10 @@ getSplitTerm (SplitDelete a) = a
|
||||
getSplitTerm (SplitReplace a) = a
|
||||
|
||||
-- | Get the range of a SplitDiff.
|
||||
getRange :: HasField fields Range => SplitDiff leaf (Record fields) -> Range
|
||||
getRange :: Functor f => HasField fields Range => SplitDiff f (Record fields) -> Range
|
||||
getRange diff = characterRange $ case runFree diff of
|
||||
Free annotated -> headF annotated
|
||||
Pure patch -> extract (getSplitTerm patch)
|
||||
|
||||
-- | A diff with only one side’s annotations.
|
||||
type SplitDiff leaf annotation = Free (CofreeF (Syntax leaf) annotation) (SplitPatch (Term leaf annotation))
|
||||
type SplitDiff f annotation = Free (TermF f annotation) (SplitPatch (Term f annotation))
|
||||
|
||||
21
src/Term.hs
21
src/Term.hs
@ -7,35 +7,34 @@ import Data.Align.Generic
|
||||
import Data.Functor.Foldable as Foldable
|
||||
import Data.Functor.Both
|
||||
import Data.These
|
||||
import Syntax
|
||||
|
||||
-- | An annotated node (Syntax) in an abstract syntax tree.
|
||||
type TermF a annotation = CofreeF (Syntax a) annotation
|
||||
type Term a annotation = Cofree (Syntax a) annotation
|
||||
type TermF = CofreeF
|
||||
type Term f = Cofree f
|
||||
|
||||
type instance Base (Cofree f a) = CofreeF f a
|
||||
instance Functor f => Foldable.Foldable (Cofree f a) where project = runCofree
|
||||
instance Functor f => Foldable.Unfoldable (Cofree f a) where embed = cofree
|
||||
type instance Base (Term f a) = TermF f a
|
||||
instance Functor f => Foldable.Foldable (Term f a) where project = runCofree
|
||||
instance Functor f => Foldable.Unfoldable (Term f a) where embed = cofree
|
||||
|
||||
-- | Zip two terms by combining their annotations into a pair of annotations.
|
||||
-- | If the structure of the two terms don't match, then Nothing will be returned.
|
||||
|
||||
zipTerms :: (Eq a, Eq annotation) => Term a annotation -> Term a annotation -> Maybe (Term a (Both annotation))
|
||||
zipTerms :: (Eq annotation, Traversable f, GAlign f) => Term f annotation -> Term f annotation -> Maybe (Term f (Both annotation))
|
||||
zipTerms t1 t2 = iter go (alignCofreeWith galign (const Nothing) both (These t1 t2))
|
||||
where go (a :< s) = cofree . (a :<) <$> sequenceA s
|
||||
|
||||
-- | Return the node count of a term.
|
||||
termSize :: (Prologue.Foldable f, Functor f) => Cofree f annotation -> Int
|
||||
termSize :: (Prologue.Foldable f, Functor f) => Term f annotation -> Int
|
||||
termSize = cata size where
|
||||
size (_ :< syntax) = 1 + sum syntax
|
||||
|
||||
-- | Aligns (zips, retaining non-overlapping portions of the structure) a pair of terms.
|
||||
alignCofreeWith :: Functor f
|
||||
=> (forall a b. f a -> f b -> Maybe (f (These a b))) -- ^ A function comparing a pair of structures, returning `Just` the combined structure if they are comparable (e.g. if they have the same constructor), and `Nothing` otherwise. The 'Data.Align.Generic.galign' function is usually what you want here.
|
||||
-> (These (Cofree f a) (Cofree f b) -> contrasted) -- ^ A function mapping a 'These' of incomparable terms into 'Pure' values in the resulting tree.
|
||||
-> (These (Term f a) (Term f b) -> contrasted) -- ^ A function mapping a 'These' of incomparable terms into 'Pure' values in the resulting tree.
|
||||
-> (a -> b -> combined) -- ^ A function mapping the input terms’ annotations into annotations in the 'Free' values in the resulting tree.
|
||||
-> These (Cofree f a) (Cofree f b) -- ^ The input terms.
|
||||
-> Free (CofreeF f combined) contrasted
|
||||
-> These (Term f a) (Term f b) -- ^ The input terms.
|
||||
-> Free (TermF f combined) contrasted
|
||||
alignCofreeWith compare contrast combine = go
|
||||
where go terms = fromMaybe (pure (contrast terms)) $ case terms of
|
||||
These t1 t2 -> wrap . (combine (extract t1) (extract t2) :<) . fmap go <$> compare (unwrap t1) (unwrap t2)
|
||||
|
||||
@ -11,10 +11,10 @@ import Test.QuickCheck hiding (Fixed)
|
||||
data ArbitraryTerm leaf annotation = ArbitraryTerm { annotation :: annotation, syntax :: Syntax leaf (ArbitraryTerm leaf annotation)}
|
||||
deriving (Show, Eq, Generic)
|
||||
|
||||
unArbitraryTerm :: ArbitraryTerm leaf annotation -> TermF leaf annotation (ArbitraryTerm leaf annotation)
|
||||
unArbitraryTerm :: ArbitraryTerm leaf annotation -> TermF (Syntax leaf) annotation (ArbitraryTerm leaf annotation)
|
||||
unArbitraryTerm (ArbitraryTerm a s) = a :< s
|
||||
|
||||
toTerm :: ArbitraryTerm leaf annotation -> Term leaf annotation
|
||||
toTerm :: ArbitraryTerm leaf annotation -> Term (Syntax leaf) annotation
|
||||
toTerm = unfold unArbitraryTerm
|
||||
|
||||
termOfSize :: (Arbitrary leaf, Arbitrary annotation) => Int -> Gen (ArbitraryTerm leaf annotation)
|
||||
@ -26,7 +26,7 @@ arbitraryTermSize = cata (succ . sum) . toTerm
|
||||
|
||||
-- Instances
|
||||
|
||||
type instance Base (ArbitraryTerm leaf annotation) = TermF leaf annotation
|
||||
type instance Base (ArbitraryTerm leaf annotation) = TermF (Syntax leaf) annotation
|
||||
instance Unfoldable (ArbitraryTerm leaf annotation) where embed (a :< s) = ArbitraryTerm a s
|
||||
|
||||
instance (Eq leaf, Eq annotation, Arbitrary leaf, Arbitrary annotation) => Arbitrary (ArbitraryTerm leaf annotation) where
|
||||
|
||||
@ -32,7 +32,7 @@ spec :: Spec
|
||||
spec = parallel $ do
|
||||
describe "alignBranch" $ do
|
||||
it "produces symmetrical context" $
|
||||
alignBranch getRange ([] :: [Join These (SplitDiff String (Record '[Range]))]) (both [Range 0 2, Range 2 4] [Range 0 2, Range 2 4]) `shouldBe`
|
||||
alignBranch getRange ([] :: [Join These (SplitDiff (Syntax String) (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, [])
|
||||
@ -40,7 +40,7 @@ spec = parallel $ do
|
||||
]
|
||||
|
||||
it "produces asymmetrical context" $
|
||||
alignBranch getRange ([] :: [Join These (SplitDiff String (Record '[Range]))]) (both [Range 0 2, Range 2 4] [Range 0 1]) `shouldBe`
|
||||
alignBranch getRange ([] :: [Join These (SplitDiff (Syntax String) (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, []))
|
||||
@ -257,13 +257,13 @@ instance Arbitrary 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 Char) -> ConstructibleFree (Patch (Term String (Record '[Range]))) (Both (Record '[Range])) -> PrettyDiff (SplitDiff String (Record '[Range]))
|
||||
align :: Both (Source.Source Char) -> ConstructibleFree (Patch (Term (Syntax String) (Record '[Range]))) (Both (Record '[Range])) -> PrettyDiff (SplitDiff (Syntax String) (Record '[Range]))
|
||||
align sources = PrettyDiff sources . fmap (fmap (getRange &&& identity)) . alignDiff sources . deconstruct
|
||||
|
||||
info :: Int -> Int -> Record '[Range]
|
||||
info start end = Range start end .: RNil
|
||||
|
||||
prettyDiff :: Both (Source.Source Char) -> [Join These (ConstructibleFree (SplitPatch (Term String (Record '[Range]))) (Record '[Range]))] -> PrettyDiff (SplitDiff String (Record '[Range]))
|
||||
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))
|
||||
|
||||
data PrettyDiff a = PrettyDiff { unPrettySources :: Both (Source.Source Char), unPrettyLines :: [Join These (Range, a)] }
|
||||
@ -282,14 +282,14 @@ newtype ConstructibleFree patch annotation = ConstructibleFree { deconstruct ::
|
||||
|
||||
|
||||
class PatchConstructible p where
|
||||
insert :: Term String (Record '[Range]) -> p
|
||||
delete :: Term String (Record '[Range]) -> p
|
||||
insert :: Term (Syntax String) (Record '[Range]) -> p
|
||||
delete :: Term (Syntax String) (Record '[Range]) -> p
|
||||
|
||||
instance PatchConstructible (Patch (Term String (Record '[Range]))) where
|
||||
instance PatchConstructible (Patch (Term (Syntax String) (Record '[Range]))) where
|
||||
insert = Insert
|
||||
delete = Delete
|
||||
|
||||
instance PatchConstructible (SplitPatch (Term String (Record '[Range]))) where
|
||||
instance PatchConstructible (SplitPatch (Term (Syntax String) (Record '[Range]))) where
|
||||
insert = SplitInsert
|
||||
delete = SplitDelete
|
||||
|
||||
|
||||
@ -21,14 +21,14 @@ 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) (toTerm term :: Term Text (Record '[Text])) `shouldSatisfy` all ((== (positively p)) . length . stem . rhead)
|
||||
\ (term, p, q) -> pqGramDecorator (rhead . headF) (positively p) (positively q) (toTerm term :: Term (Syntax Text) (Record '[Text])) `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) (toTerm term :: Term Text (Record '[Text])) `shouldSatisfy` all ((== (positively q)) . length . base . rhead)
|
||||
\ (term, p, q) -> pqGramDecorator (rhead . headF) (positively p) (positively q) (toTerm term :: Term (Syntax Text) (Record '[Text])) `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) (toTerm term :: Term Text (Record '[Text])) `shouldSatisfy` all ((== (positively d)) . length . rhead)
|
||||
\ (term, p, q, d) -> featureVectorDecorator (rhead . headF) (positively p) (positively q) (positively d) (toTerm term :: Term (Syntax Text) (Record '[Text])) `shouldSatisfy` all ((== (positively d)) . length . rhead)
|
||||
|
||||
describe "rws" $ do
|
||||
let decorate = defaultFeatureVectorDecorator (category . headF)
|
||||
|
||||
@ -26,7 +26,7 @@ arrayInfo = ArrayLiteral .: Range 0 3 .: RNil
|
||||
literalInfo :: Record '[Category, Range]
|
||||
literalInfo = StringLiteral .: Range 1 2 .: RNil
|
||||
|
||||
testDiff :: Diff Text (Record '[Category, Range])
|
||||
testDiff :: Diff (Syntax Text) (Record '[Category, Range])
|
||||
testDiff = free $ Free (pure arrayInfo :< Indexed [ free $ Pure (Insert (cofree $ literalInfo :< Leaf "a")) ])
|
||||
|
||||
testSummary :: DiffSummary DiffInfo
|
||||
@ -67,7 +67,7 @@ spec = parallel $ do
|
||||
extractLeaves (BranchInfo children _ _) = join $ extractLeaves <$> children
|
||||
extractLeaves leaf = [ leaf ]
|
||||
|
||||
extractDiffLeaves :: Term Text (Record '[Category, Range]) -> [ Term Text (Record '[Category, Range]) ]
|
||||
extractDiffLeaves :: Term (Syntax Text) (Record '[Category, Range]) -> [ Term (Syntax Text) (Record '[Category, Range]) ]
|
||||
extractDiffLeaves term = case unwrap term of
|
||||
(Indexed children) -> join $ extractDiffLeaves <$> children
|
||||
(Fixed children) -> join $ extractDiffLeaves <$> children
|
||||
@ -81,7 +81,7 @@ spec = parallel $ do
|
||||
in
|
||||
length listOfLeaves `shouldBe` length listOfDiffLeaves
|
||||
|
||||
isIndexedOrFixed :: Patch (Term a annotation) -> Bool
|
||||
isIndexedOrFixed :: Patch (Term (Syntax a) annotation) -> Bool
|
||||
isIndexedOrFixed = any (isIndexedOrFixed' . unwrap)
|
||||
|
||||
isIndexedOrFixed' :: Syntax a f -> Bool
|
||||
|
||||
Loading…
Reference in New Issue
Block a user