1
1
mirror of https://github.com/github/semantic.git synced 2024-11-28 01:47:01 +03:00

Generalize Term/TermF & Diff/DiffF over the functor.

This commit is contained in:
Rob Rix 2016-09-09 14:46:50 -04:00
parent fe7854ad6e
commit 98637ad656
19 changed files with 103 additions and 101 deletions

View File

@ -38,15 +38,15 @@ numberedRows = countUp (both 1 1)
nextLineNumbers from row = modifyJoin (fromThese identity identity) (succ <$ row) <*> from nextLineNumbers from row = modifyJoin (fromThese identity identity) (succ <$ row) <*> from
-- | Determine whether a line contains any patches. -- | 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 <$) hasChanges = or . (True <$)
-- | Align a Diff into a list of Join These SplitDiffs representing the (possibly blank) lines on either side. -- | 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) 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. -- | 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 alignPatch sources patch = case patch of
Delete term -> fmap (pure . SplitDelete) <$> alignSyntax' this (fst sources) term Delete term -> fmap (pure . SplitDelete) <$> alignSyntax' this (fst sources) term
Insert term -> fmap (pure . SplitInsert) <$> alignSyntax' that (snd 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' this (fst sources) term1)
(alignSyntax' that (snd sources) term2) (alignSyntax' that (snd sources) term2)
where getRange = characterRange . extract 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) alignSyntax' side source term = hylo (alignSyntax side cofree getRange (Identity source)) runCofree (Identity <$> term)
this = Join . This . runIdentity this = Join . This . runIdentity
that = Join . That . 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. -- | 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 alignSyntax toJoinThese toNode getRange sources (infos :< syntax) = catMaybes $ case syntax of
Leaf s -> wrapInBranch (const (Leaf s)) <$> alignBranch getRange [] bothRanges Leaf s -> wrapInBranch (const (Leaf s)) <$> alignBranch getRange [] bothRanges
Syntax.Comment a -> wrapInBranch (const (Syntax.Comment a)) <$> alignBranch getRange [] bothRanges Syntax.Comment a -> wrapInBranch (const (Syntax.Comment a)) <$> alignBranch getRange [] bothRanges

View File

@ -7,34 +7,33 @@ import Data.Functor.Foldable as Foldable
import Data.Functor.Both as Both import Data.Functor.Both as Both
import Data.Mergeable import Data.Mergeable
import Patch import Patch
import Syntax
import Term import Term
-- | An annotated series of patches of terms. -- | An annotated series of patches of terms.
type DiffF leaf annotation = FreeF (CofreeF (Syntax leaf) (Both annotation)) (Patch (Term leaf annotation)) type DiffF f annotation = FreeF (TermF f (Both annotation)) (Patch (Term f annotation))
type Diff a annotation = Free (CofreeF (Syntax a) (Both annotation)) (Patch (Term a annotation)) type Diff f annotation = Free (TermF f (Both annotation)) (Patch (Term f annotation))
type instance Base (Free f a) = FreeF f a type instance Base (Free f a) = FreeF f a
instance Functor f => Foldable.Foldable (Free f a) where project = runFree instance Functor f => Foldable.Foldable (Free f a) where project = runFree
instance Functor f => Foldable.Unfoldable (Free f a) where embed = free 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 diffSum patchCost diff = sum $ fmap patchCost diff
-- | The sum of the node count of the diffs patches. -- | The sum of the node count of the diffs patches.
diffCost :: Diff a annotation -> Int diffCost :: (Prologue.Foldable f, Functor f) => Diff f annotation -> Int
diffCost = diffSum $ patchSum termSize 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. -- | 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 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 algebra (annotations :< syntax) = cofree . (Both.fst annotations :<) <$> sequenceAlt syntax
-- | Recover the before state of a diff. -- | 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 beforeTerm = mergeMaybe before
-- | Recover the after state of a diff. -- | 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 afterTerm = mergeMaybe after

View File

@ -3,11 +3,13 @@ module Diff.Arbitrary where
import Diff import Diff
import Data.Bifunctor.Join import Data.Bifunctor.Join
import Data.Bifunctor.Join.Arbitrary () import Data.Bifunctor.Join.Arbitrary ()
import Data.Functor.Both
import Data.Functor.Foldable (unfold) import Data.Functor.Foldable (unfold)
import Patch import Patch
import Patch.Arbitrary () import Patch.Arbitrary ()
import Syntax import Syntax
import Prologue import Prologue
import Term
import Term.Arbitrary import Term.Arbitrary
import Test.QuickCheck hiding (Fixed) import Test.QuickCheck hiding (Fixed)
@ -16,11 +18,11 @@ data ArbitraryDiff leaf annotation
| ArbitraryPure (Patch (ArbitraryTerm leaf annotation)) | ArbitraryPure (Patch (ArbitraryTerm leaf annotation))
deriving (Show, Eq, Generic) 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 (ArbitraryFree a s) = Free (a :< s)
unArbitraryDiff (ArbitraryPure p) = Pure p 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 toDiff = fmap (fmap toTerm) . unfold unArbitraryDiff
diffOfSize :: (Arbitrary leaf, Arbitrary annotation) => Int -> Gen (ArbitraryDiff leaf annotation) diffOfSize :: (Arbitrary leaf, Arbitrary annotation) => Int -> Gen (ArbitraryDiff leaf annotation)

View File

@ -24,7 +24,7 @@ import Source
data Identifiable a = Identifiable a | Unidentifiable a 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 = isIdentifiable term =
case unwrap term of case unwrap term of
S.FunctionCall _ _ -> True S.FunctionCall _ _ -> True
@ -38,7 +38,7 @@ isIdentifiable term =
S.Leaf _ -> True S.Leaf _ -> True
_ -> False _ -> 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 identifiable term = if isIdentifiable term then Identifiable term else Unidentifiable term
data DiffInfo = LeafInfo { categoryName :: Text, termName :: Text } data DiffInfo = LeafInfo { categoryName :: Text, termName :: Text }
@ -54,7 +54,7 @@ data DiffSummary a = DiffSummary {
} deriving (Eq, Functor, Show, Generic) } deriving (Eq, Functor, Show, Generic)
-- Returns a list of diff summary texts given two source blobs and a diff. -- 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 diffSummaries blobs diff = summaryToTexts =<< diffToDiffSummaries (source <$> blobs) diff
-- Takes a 'DiffSummary' and returns a list of summary texts representing the LeafInfos -- 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) summaryToTexts DiffSummary{..} = runJoin . fmap (show . (P.<> maybeParentContext parentAnnotation)) <$> (Join <$> summaries patch)
-- Returns a list of 'DiffSummary' given two source blobs and a diff. -- 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 -> diffToDiffSummaries sources = para $ \diff ->
let diff' = free (Prologue.fst <$> diff) let diff' = free (Prologue.fst <$> diff)
annotateWithCategory :: [(Diff leaf (Record fields), [DiffSummary DiffInfo])] -> [DiffSummary DiffInfo] annotateWithCategory :: [(Diff leaf (Record fields), [DiffSummary DiffInfo])] -> [DiffSummary DiffInfo]
@ -104,7 +104,7 @@ toLeafInfos BranchInfo{..} = toLeafInfos =<< branches
toLeafInfos err@ErrorInfo{} = pure (pretty err) toLeafInfos err@ErrorInfo{} = pure (pretty err)
-- Returns a text representing a specific term given a source and a term. -- 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 toTermName source term = case unwrap term of
S.AnonymousFunction _ _ -> "anonymous" S.AnonymousFunction _ _ -> "anonymous"
S.Fixed children -> fromMaybe "branch" $ (toCategoryName . category) . extract <$> head children 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) termNameFromSource term = termNameFromRange (range term)
termNameFromRange range = toText $ Source.slice range source termNameFromRange range = toText $ Source.slice range source
range = characterRange . extract 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 toArgName arg = case identifiable arg of
Identifiable arg -> toTermName' arg Identifiable arg -> toTermName' arg
Unidentifiable _ -> "..." Unidentifiable _ -> "..."
@ -174,7 +174,7 @@ maybeParentContext = maybe "" (\annotation ->
toDoc :: Text -> Doc toDoc :: Text -> Doc
toDoc = string . toS 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 termToDiffInfo blob term = case unwrap term of
Leaf _ -> LeafInfo (toCategoryName term) (toTermName' term) Leaf _ -> LeafInfo (toCategoryName term) (toTermName' term)
S.AnonymousFunction _ _ -> LeafInfo (toCategoryName term) ("anonymous") S.AnonymousFunction _ _ -> LeafInfo (toCategoryName term) ("anonymous")
@ -193,7 +193,7 @@ termToDiffInfo blob term = case unwrap term of
where toTermName' = toTermName blob where toTermName' = toTermName blob
termToDiffInfo' = termToDiffInfo 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 = prependSummary source term summary =
case (parentAnnotation summary, identifiable term) of case (parentAnnotation summary, identifiable term) of
(Nothing, Identifiable term) -> summary { parentAnnotation = Just (category . extract $ term, toTermName source term) } (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.CommaOperator -> "comma operator"
C.Empty -> "empty statement" 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 toCategoryName = toCategoryName . category . extract
instance Arbitrary Branch where instance Arbitrary Branch where

View File

@ -93,7 +93,7 @@ parserForFilepath path blob = decorateTerm termCostDecorator <$> do
pure $! breakDownLeavesByWord (source blob) parsed pure $! breakDownLeavesByWord (source blob) parsed
-- | Replace every string leaf with leaves of the words in the string. -- | 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 breakDownLeavesByWord source = cata replaceIn
where where
replaceIn (info :< syntax) = cofree $ info :< syntax' 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) termCostDecorator c = 1 + sum (cost <$> tailF c)
-- | Determine whether two terms are comparable based on the equality of their categories. -- | 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 compareCategoryEq = (==) `on` category . extract
-- | The sum of the node count of the diffs patches. -- | The sum of the node count of the diffs 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 diffCostWithCachedTermCosts diff = unCost $ case runFree diff of
Free (info :< _) -> sum (cost <$> info) Free (info :< _) -> sum (cost <$> info)
Pure patch -> sum (cost . extract <$> patch) Pure patch -> sum (cost . extract <$> patch)

View File

@ -19,23 +19,23 @@ import Syntax as S
import Term import Term
-- | Returns whether two terms are comparable -- | 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. -- | 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. -- | Diff two terms recursively, given functions characterizing the diffing.
diffTerms :: (Eq leaf, Eq (Record fields), HasField fields Category, HasField fields (Vector.Vector Double)) 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. => DiffConstructor (Syntax 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. -> Comparable (Syntax 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. -> SES.Cost (Diff (Syntax 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 (Syntax leaf) (Record fields) -- ^ A term representing the old state.
-> Term leaf (Record fields) -- ^ A term representing the new state. -> Term (Syntax leaf) (Record fields) -- ^ A term representing the new state.
-> Diff leaf (Record fields) -> Diff (Syntax leaf) (Record fields)
diffTerms construct comparable cost a b = fromMaybe (replacing a b) $ diffComparableTerms construct comparable cost a b 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'. -- | 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 diffComparableTerms construct comparable cost = recur
where recur a b where recur a b
| (category <$> a) == (category <$> b) = hylo construct runCofree <$> zipTerms a b | (category <$> a) == (category <$> b) = hylo construct runCofree <$> zipTerms a b
@ -43,7 +43,7 @@ diffComparableTerms construct comparable cost = recur
| otherwise = Nothing | otherwise = Nothing
-- | Construct an algorithm to diff a pair of terms. -- | 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 algorithmWithTerms construct t1 t2 = case (unwrap t1, unwrap t2) of
(Indexed a, Indexed b) -> branch Indexed a b (Indexed a, Indexed b) -> branch Indexed a b
(S.FunctionCall identifierA argsA, S.FunctionCall identifierB argsB) -> do (S.FunctionCall identifierA argsA, S.FunctionCall identifierB argsB) -> do

View File

@ -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). -> 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. -> Text -- ^ The name of the production for this node.
-> Range -- ^ The character range that the term occupies. -> Range -- ^ The character range that the term occupies.
-> [Term Text (Record '[Range, Category])] -- ^ The child nodes of the term. -> [Term (S.Syntax Text) (Record '[Range, Category])] -- ^ The child nodes of the term.
-> IO (Term Text (Record '[Range, Category])) -- ^ The resulting term, in IO. -> IO (Term (S.Syntax Text) (Record '[Range, Category])) -- ^ The resulting term, in IO.
termConstructor source sourceSpan name range children = termConstructor source sourceSpan name range children =
withDefaultInfo <$> case (name, children) of withDefaultInfo <$> case (name, children) of
("ERROR", _) -> S.Error <$> sourceSpan <*> pure children ("ERROR", _) -> S.Error <$> sourceSpan <*> pure children

View File

@ -6,6 +6,7 @@ import Info
import Prologue import Prologue
import Source import Source
import SourceSpan import SourceSpan
import Syntax
import qualified Syntax as S import qualified Syntax as S
import Term 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). -> 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. -> Text -- ^ The name of the production for this node.
-> Range -- ^ The character range that the term occupies. -> Range -- ^ The character range that the term occupies.
-> [Term Text (Record '[Range, Category])] -- ^ The child nodes of the term. -> [Term (Syntax Text) (Record '[Range, Category])] -- ^ The child nodes of the term.
-> IO (Term Text (Record '[Range, Category])) -- ^ The resulting term, in IO. -> IO (Term (Syntax Text) (Record '[Range, Category])) -- ^ The resulting term, in IO.
termConstructor source sourceSpan name range children termConstructor source sourceSpan name range children
| name == "ERROR" = sourceSpan >>= withDefaultInfo . (`S.Error` children) | name == "ERROR" = sourceSpan >>= withDefaultInfo . (`S.Error` children)
| otherwise = withDefaultInfo $ case (name, children) of | otherwise = withDefaultInfo $ case (name, children) of

View File

@ -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). -> 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. -> Text -- ^ The name of the production for this node.
-> Range -- ^ The character range that the term occupies. -> Range -- ^ The character range that the term occupies.
-> [Term Text (Record '[Range, Category])] -- ^ The child nodes of the term. -> [Term (S.Syntax Text) (Record '[Range, Category])] -- ^ The child nodes of the term.
-> IO (Term Text (Record '[Range, Category])) -- ^ The resulting term, in IO. -> IO (Term (S.Syntax Text) (Record '[Range, Category])) -- ^ The resulting term, in IO.
termConstructor source sourceSpan name range children termConstructor source sourceSpan name range children
| name == "ERROR" = sourceSpan >>= withDefaultInfo . (`S.Error` children) | name == "ERROR" = sourceSpan >>= withDefaultInfo . (`S.Error` children)
| otherwise = withDefaultInfo $ case (name, children) of | otherwise = withDefaultInfo $ case (name, children) of
@ -136,10 +136,10 @@ categoryForJavaScriptProductionName name = case name of
"rel_op" -> RelationalOperator "rel_op" -> RelationalOperator
_ -> Other name _ -> 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) 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.Indexed [key,value] <- unwrap child = [cofree (extract child :< S.Pair key value)]
toTuple child | S.Fixed [key,value] <- unwrap child = [cofree (extract child :< S.Pair key value)] toTuple child | S.Fixed [key,value] <- unwrap child = [cofree (extract child :< S.Pair key value)]
toTuple child | S.Leaf c <- unwrap child = [cofree (extract child :< S.Comment c)] toTuple child | S.Leaf c <- unwrap child = [cofree (extract child :< S.Comment c)]

View File

@ -1,16 +1,17 @@
module Renderer (Renderer, DiffArguments(..), Output(..), concatOutputs, toSummaryKey, Format(..)) where 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 (Value, toEncoding)
import Data.Aeson.Encoding (encodingToLazyByteString) import Data.Aeson.Encoding (encodingToLazyByteString)
import Data.Functor.Both
import Data.Map as Map hiding (null) 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. -- | 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 } data DiffArguments = DiffArguments { format :: Format, output :: Maybe FilePath, outputPath :: FilePath }
deriving (Show) deriving (Show)

View File

@ -32,7 +32,7 @@ json blobs diff = JSONOutput $ Map.fromList [
-- | A numbered 'a'. -- | A numbered 'a'.
newtype NumberedLine a = NumberedLine (Int, 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)) toJSON (NumberedLine (n, a)) = object (lineFields n a (getRange a))
toEncoding (NumberedLine (n, a)) = pairs $ mconcat (lineFields n a (getRange a)) toEncoding (NumberedLine (n, a)) = pairs $ mconcat (lineFields n a (getRange a))
instance ToJSON Category where instance ToJSON Category where
@ -46,18 +46,18 @@ instance ToJSON a => ToJSON (Join These a) where
toEncoding = foldable toEncoding = foldable
instance ToJSON a => ToJSON (Join (,) a) where instance ToJSON a => ToJSON (Join (,) a) where
toJSON (Join (a, b)) = A.Array . Vector.fromList $ toJSON <$> [ a, b ] 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 toJSON splitDiff = case runFree splitDiff of
(Free (info :< syntax)) -> object (termFields info syntax) (Free (info :< syntax)) -> object (termFields info syntax)
(Pure patch) -> object (patchFields patch) (Pure patch) -> object (patchFields patch)
toEncoding splitDiff = case runFree splitDiff of toEncoding splitDiff = case runFree splitDiff of
(Free (info :< syntax)) -> pairs $ mconcat (termFields info syntax) (Free (info :< syntax)) -> pairs $ mconcat (termFields info syntax)
(Pure patch) -> pairs $ mconcat (patchFields patch) (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) toJSON term | (info :< syntax) <- runCofree term = object (termFields info syntax)
toEncoding term | (info :< syntax) <- runCofree term = pairs $ mconcat (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 lineFields n term range = [ "number" .= n
, "terms" .= [ term ] , "terms" .= [ term ]
, "range" .= range , "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 ] S.Method identifier params definitions -> [ "methodIdentifier" .= identifier ] <> [ "params" .= params ] <> [ "definitions" .= definitions ]
where childrenFields c = [ "children" .= c ] 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 patchFields patch = case patch of
SplitInsert term -> fields "insert" term SplitInsert term -> fields "insert" term
SplitDelete term -> fields "delete" term SplitDelete term -> fields "delete" term

View File

@ -20,6 +20,7 @@ import Range
import Renderer import Renderer
import Source hiding (break) import Source hiding (break)
import SplitDiff import SplitDiff
import Syntax
-- | Render a timed out file as a truncated diff. -- | Render a timed out file as a truncated diff.
truncatePatch :: DiffArguments -> Both SourceBlob -> Text 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 <$) rowIncrement = Join . fromThese (Sum 0) (Sum 0) . runJoin . (Sum 1 <$)
-- | Given the before and after sources, render a hunk to a string. -- | 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 <> showHunk blobs hunk = maybeOffsetHeader <>
concat (showChange sources <$> changes hunk) <> concat (showChange sources <$> changes hunk) <>
showLines (snd sources) ' ' (maybeSnd . runJoin <$> trailingContext hunk) showLines (snd sources) ' ' (maybeSnd . runJoin <$> trailingContext hunk)
@ -66,18 +67,18 @@ showHunk blobs hunk = maybeOffsetHeader <>
(offsetA, offsetB) = runJoin . fmap (show . getSum) $ offset hunk (offsetA, offsetB) = runJoin . fmap (show . getSum) $ offset hunk
-- | Given the before and after sources, render a change to a string. -- | 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 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)) 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. -- | 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 showLines source prefix lines = fromMaybe "" . mconcat $ fmap prepend . showLine source <$> lines
where prepend "" = "" where prepend "" = ""
prepend source = prefix : source prepend source = prefix : source
-- | Given a source, render a line to a string. -- | 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 showLine source line | Just line <- line = Just . toString . (`slice` source) $ getRange line
| otherwise = Nothing | otherwise = Nothing
@ -116,7 +117,7 @@ emptyHunk :: Hunk (SplitDiff a annotation)
emptyHunk = Hunk { offset = mempty, changes = [], trailingContext = [] } emptyHunk = Hunk { offset = mempty, changes = [], trailingContext = [] }
-- | Render a diff as a series of hunks. -- | 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 hunks _ blobs | sources <- source <$> blobs
, sourcesEqual <- runBothWith (==) sources , sourcesEqual <- runBothWith (==) sources
, sourcesNull <- runBothWith (&&) (null <$> 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 -- | Given beginning line numbers, turn rows in a split diff into hunks in a
-- | patch. -- | 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 hunksInRows start rows = case nextHunk start rows of
Nothing -> [] Nothing -> []
Just (hunk, rest) -> hunk : hunksInRows (offset hunk <> hunkLength hunk) rest Just (hunk, rest) -> hunk : hunksInRows (offset hunk <> hunkLength hunk) rest
-- | Given beginning line numbers, return the next hunk and the remaining rows -- | Given beginning line numbers, return the next hunk and the remaining rows
-- | of the split diff. -- | 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 nextHunk start rows = case nextChange start rows of
Nothing -> Nothing Nothing -> Nothing
Just (offset, change, rest) -> let (changes, rest') = contiguousChanges rest in Just (Hunk offset (change : changes) $ take 3 rest', drop 3 rest') 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 -- | Given beginning line numbers, return the number of lines to the next
-- | the next change, and the remaining rows of the split diff. -- | 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 nextChange start rows = case changeIncludingContext leadingContext afterLeadingContext of
Nothing -> Nothing Nothing -> Nothing
Just (change, afterChanges) -> Just (start <> mconcat (rowIncrement <$> skippedContext), change, afterChanges) 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 -- | 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 -- | the given rows that have changes, or Nothing if the first row has no
-- | changes. -- | 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 changeIncludingContext leadingContext rows = case changes of
[] -> Nothing [] -> Nothing
_ -> Just (Change leadingContext changes, afterChanges) _ -> Just (Change leadingContext changes, afterChanges)
where (changes, afterChanges) = span rowHasChanges rows where (changes, afterChanges) = span rowHasChanges rows
-- | Whether a row has changes on either side. -- | 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) rowHasChanges row = or (hasChanges <$> row)

View File

@ -147,10 +147,10 @@ instance (ToMarkup f, HasField fields Category, HasField fields Cost, HasField f
Leaf _ -> span . string . toString $ slice (characterRange info) source Leaf _ -> span . string . toString $ slice (characterRange info) source
_ -> ul . mconcat $ wrapIn li <$> contentElements source (characterRange info) (toList syntax) _ -> 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 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 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 where toMarkupAndRange patch = let term@(info :< _) = runCofree $ getSplitTerm patch in
((div ! patchAttribute patch `withCostAttribute` cost info) . toMarkup $ Renderable source (cofree term), characterRange info) ((div ! patchAttribute patch `withCostAttribute` cost info) . toMarkup $ Renderable source (cofree term), characterRange info)

View File

@ -3,8 +3,7 @@ module SplitDiff where
import Data.Record import Data.Record
import Info import Info
import Prologue import Prologue
import Syntax import Term (Term, TermF)
import Term (Term)
-- | A patch to only one side of a diff. -- | A patch to only one side of a diff.
data SplitPatch a = SplitInsert a | SplitDelete a | SplitReplace a data SplitPatch a = SplitInsert a | SplitDelete a | SplitReplace a
@ -17,10 +16,10 @@ getSplitTerm (SplitDelete a) = a
getSplitTerm (SplitReplace a) = a getSplitTerm (SplitReplace a) = a
-- | Get the range of a SplitDiff. -- | 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 getRange diff = characterRange $ case runFree diff of
Free annotated -> headF annotated Free annotated -> headF annotated
Pure patch -> extract (getSplitTerm patch) Pure patch -> extract (getSplitTerm patch)
-- | A diff with only one sides annotations. -- | A diff with only one sides 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))

View File

@ -7,35 +7,34 @@ import Data.Align.Generic
import Data.Functor.Foldable as Foldable import Data.Functor.Foldable as Foldable
import Data.Functor.Both import Data.Functor.Both
import Data.These import Data.These
import Syntax
-- | An annotated node (Syntax) in an abstract syntax tree. -- | An annotated node (Syntax) in an abstract syntax tree.
type TermF a annotation = CofreeF (Syntax a) annotation type TermF = CofreeF
type Term a annotation = Cofree (Syntax a) annotation type Term f = Cofree f
type instance Base (Cofree f a) = CofreeF f a type instance Base (Term f a) = TermF f a
instance Functor f => Foldable.Foldable (Cofree f a) where project = runCofree instance Functor f => Foldable.Foldable (Term f a) where project = runCofree
instance Functor f => Foldable.Unfoldable (Cofree f a) where embed = cofree instance Functor f => Foldable.Unfoldable (Term f a) where embed = cofree
-- | Zip two terms by combining their annotations into a pair of annotations. -- | 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. -- | 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)) zipTerms t1 t2 = iter go (alignCofreeWith galign (const Nothing) both (These t1 t2))
where go (a :< s) = cofree . (a :<) <$> sequenceA s where go (a :< s) = cofree . (a :<) <$> sequenceA s
-- | Return the node count of a term. -- | 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 termSize = cata size where
size (_ :< syntax) = 1 + sum syntax size (_ :< syntax) = 1 + sum syntax
-- | Aligns (zips, retaining non-overlapping portions of the structure) a pair of terms. -- | Aligns (zips, retaining non-overlapping portions of the structure) a pair of terms.
alignCofreeWith :: Functor f 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. => (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. -> (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. -> These (Term f a) (Term f b) -- ^ The input terms.
-> Free (CofreeF f combined) contrasted -> Free (TermF f combined) contrasted
alignCofreeWith compare contrast combine = go alignCofreeWith compare contrast combine = go
where go terms = fromMaybe (pure (contrast terms)) $ case terms of 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) These t1 t2 -> wrap . (combine (extract t1) (extract t2) :<) . fmap go <$> compare (unwrap t1) (unwrap t2)

View File

@ -11,10 +11,10 @@ import Test.QuickCheck hiding (Fixed)
data ArbitraryTerm leaf annotation = ArbitraryTerm { annotation :: annotation, syntax :: Syntax leaf (ArbitraryTerm leaf annotation)} data ArbitraryTerm leaf annotation = ArbitraryTerm { annotation :: annotation, syntax :: Syntax leaf (ArbitraryTerm leaf annotation)}
deriving (Show, Eq, Generic) 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 unArbitraryTerm (ArbitraryTerm a s) = a :< s
toTerm :: ArbitraryTerm leaf annotation -> Term leaf annotation toTerm :: ArbitraryTerm leaf annotation -> Term (Syntax leaf) annotation
toTerm = unfold unArbitraryTerm toTerm = unfold unArbitraryTerm
termOfSize :: (Arbitrary leaf, Arbitrary annotation) => Int -> Gen (ArbitraryTerm leaf annotation) termOfSize :: (Arbitrary leaf, Arbitrary annotation) => Int -> Gen (ArbitraryTerm leaf annotation)
@ -26,7 +26,7 @@ arbitraryTermSize = cata (succ . sum) . toTerm
-- Instances -- 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 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 instance (Eq leaf, Eq annotation, Arbitrary leaf, Arbitrary annotation) => Arbitrary (ArbitraryTerm leaf annotation) where

View File

@ -32,7 +32,7 @@ spec :: Spec
spec = parallel $ do spec = parallel $ do
describe "alignBranch" $ do describe "alignBranch" $ do
it "produces symmetrical context" $ it "produces symmetrical context" $
alignBranch getRange ([] :: [Join These (SplitDiff 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, []) [ Join (These (Range 0 2, [])
(Range 0 2, [])) (Range 0 2, []))
, Join (These (Range 2 4, []) , Join (These (Range 2 4, [])
@ -40,7 +40,7 @@ spec = parallel $ do
] ]
it "produces asymmetrical context" $ 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, []) [ Join (These (Range 0 2, [])
(Range 0 1, [])) (Range 0 1, []))
, Join (This (Range 2 4, [])) , Join (This (Range 2 4, []))
@ -257,13 +257,13 @@ instance Arbitrary BranchElement where
counts :: [Join These (Int, a)] -> Both Int counts :: [Join These (Int, a)] -> Both Int
counts numbered = fromMaybe 0 . getLast . mconcat . fmap Last <$> Join (unalign (runJoin . fmap Prologue.fst <$> numbered)) counts numbered = fromMaybe 0 . getLast . mconcat . fmap Last <$> Join (unalign (runJoin . fmap Prologue.fst <$> numbered))
align :: Both (Source.Source 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 align sources = PrettyDiff sources . fmap (fmap (getRange &&& identity)) . alignDiff sources . deconstruct
info :: Int -> Int -> Record '[Range] info :: Int -> Int -> Record '[Range]
info start end = Range start end .: RNil 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)) prettyDiff sources = PrettyDiff sources . fmap (fmap ((getRange &&& identity) . deconstruct))
data PrettyDiff a = PrettyDiff { unPrettySources :: Both (Source.Source Char), unPrettyLines :: [Join These (Range, a)] } 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 class PatchConstructible p where
insert :: Term String (Record '[Range]) -> p insert :: Term (Syntax String) (Record '[Range]) -> p
delete :: Term 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 insert = Insert
delete = Delete delete = Delete
instance PatchConstructible (SplitPatch (Term String (Record '[Range]))) where instance PatchConstructible (SplitPatch (Term (Syntax String) (Record '[Range]))) where
insert = SplitInsert insert = SplitInsert
delete = SplitDelete delete = SplitDelete

View File

@ -21,14 +21,14 @@ spec = parallel $ do
let positively = succ . abs let positively = succ . abs
describe "pqGramDecorator" $ do describe "pqGramDecorator" $ do
prop "produces grams with stems of the specified length" $ 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" $ 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 describe "featureVectorDecorator" $ do
prop "produces a vector of the specified dimension" $ 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 describe "rws" $ do
let decorate = defaultFeatureVectorDecorator (category . headF) let decorate = defaultFeatureVectorDecorator (category . headF)

View File

@ -26,7 +26,7 @@ arrayInfo = ArrayLiteral .: Range 0 3 .: RNil
literalInfo :: Record '[Category, Range] literalInfo :: Record '[Category, Range]
literalInfo = StringLiteral .: Range 1 2 .: RNil 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")) ]) testDiff = free $ Free (pure arrayInfo :< Indexed [ free $ Pure (Insert (cofree $ literalInfo :< Leaf "a")) ])
testSummary :: DiffSummary DiffInfo testSummary :: DiffSummary DiffInfo
@ -67,7 +67,7 @@ spec = parallel $ do
extractLeaves (BranchInfo children _ _) = join $ extractLeaves <$> children extractLeaves (BranchInfo children _ _) = join $ extractLeaves <$> children
extractLeaves leaf = [ leaf ] 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 extractDiffLeaves term = case unwrap term of
(Indexed children) -> join $ extractDiffLeaves <$> children (Indexed children) -> join $ extractDiffLeaves <$> children
(Fixed children) -> join $ extractDiffLeaves <$> children (Fixed children) -> join $ extractDiffLeaves <$> children
@ -81,7 +81,7 @@ spec = parallel $ do
in in
length listOfLeaves `shouldBe` length listOfDiffLeaves length listOfLeaves `shouldBe` length listOfDiffLeaves
isIndexedOrFixed :: Patch (Term a annotation) -> Bool isIndexedOrFixed :: Patch (Term (Syntax a) annotation) -> Bool
isIndexedOrFixed = any (isIndexedOrFixed' . unwrap) isIndexedOrFixed = any (isIndexedOrFixed' . unwrap)
isIndexedOrFixed' :: Syntax a f -> Bool isIndexedOrFixed' :: Syntax a f -> Bool