mirror of
https://github.com/github/semantic.git
synced 2024-12-01 09:15:01 +03:00
Merge remote-tracking branch 'origin/master' into hold-on-to-your-butts
This commit is contained in:
Rob Rix
commit
80bb79f73c
@ -20,7 +20,7 @@ import Diff
|
||||
import Info
|
||||
import Patch
|
||||
import Range
|
||||
import Source hiding (break, fromList, uncons)
|
||||
import Source hiding (break, fromList)
|
||||
import SplitDiff
|
||||
import Syntax
|
||||
import Term
|
||||
@ -38,11 +38,11 @@ hasChanges :: (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) -> SyntaxDiff leaf fields -> [Join These (SplitSyntaxDiff leaf fields)]
|
||||
alignDiff :: HasField fields Range => Both Source -> SyntaxDiff leaf fields -> [Join These (SplitSyntaxDiff leaf 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 (SyntaxTerm leaf fields) -> [Join These (SplitSyntaxDiff leaf fields)]
|
||||
alignPatch :: forall fields leaf. HasField fields Range => Both Source -> Patch (SyntaxTerm leaf fields) -> [Join These (SplitSyntaxDiff leaf 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
|
||||
@ -50,13 +50,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 -> SyntaxTerm leaf fields -> [Join These (SyntaxTerm leaf fields)]
|
||||
alignSyntax' :: (forall a. Identity a -> Join These a) -> Source -> SyntaxTerm leaf fields -> [Join These (SyntaxTerm leaf 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) -> (SyntaxTermF leaf fields term -> term) -> (term -> Range) -> f (Source Char) -> TermF (Syntax leaf) (f (Record fields)) [Join These term] -> [Join These term]
|
||||
alignSyntax :: (Applicative f, HasField fields Range) => (forall a. f a -> Join These a) -> (SyntaxTermF leaf fields term -> term) -> (term -> Range) -> f Source -> 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
|
||||
|
||||
@ -284,10 +284,10 @@ pqGramDecorator getLabel p q = cata algebra
|
||||
|
||||
-- | Computes a unit vector of the specified dimension from a hash.
|
||||
unitVector :: Int -> Int -> FeatureVector
|
||||
unitVector d hash = fmap (/ magnitude) uniform
|
||||
unitVector d hash = fmap (* invMagnitude) uniform
|
||||
where
|
||||
uniform = listArray (0, d - 1) (evalRand components (pureMT (fromIntegral hash)))
|
||||
magnitude = sqrtDouble (sum (fmap (** 2) uniform))
|
||||
invMagnitude = 1 / sqrtDouble (sum (fmap (** 2) uniform))
|
||||
components = sequenceA (replicate d (liftRand randomDouble))
|
||||
|
||||
-- | Strips the head annotation off a term annotated with non-empty records.
|
||||
|
||||
@ -106,7 +106,7 @@ summaryToTexts DiffSummary{..} = appendParentContexts <$> summaries patch
|
||||
jsonSummary { summary = show $ summary jsonSummary <+> parentContexts parentAnnotation }
|
||||
|
||||
-- Returns a list of 'DiffSummary' given two source blobs and a diff.
|
||||
diffToDiffSummaries :: (StringConv leaf Text, DefaultFields fields) => Both (Source Char) -> SyntaxDiff leaf fields -> [DiffSummary DiffInfo]
|
||||
diffToDiffSummaries :: (StringConv leaf Text, DefaultFields fields) => Both Source -> SyntaxDiff leaf fields -> [DiffSummary DiffInfo]
|
||||
diffToDiffSummaries sources = para $ \diff ->
|
||||
let
|
||||
diff' = free (Prologue.fst <$> diff)
|
||||
@ -186,7 +186,7 @@ toLeafInfos LeafInfo{..} = pure $ JSONSummary (summary leafCategory termName) so
|
||||
vowels = Text.singleton <$> ("aeiouAEIOU" :: [Char])
|
||||
|
||||
-- Returns a text representing a specific term given a source and a term.
|
||||
toTermName :: forall leaf fields. (StringConv leaf Text, DefaultFields fields) => Source Char -> SyntaxTerm leaf fields -> Text
|
||||
toTermName :: forall leaf fields. (StringConv leaf Text, DefaultFields fields) => Source -> SyntaxTerm leaf fields -> Text
|
||||
toTermName source term = case unwrap term of
|
||||
S.Send _ _ -> termNameFromSource term
|
||||
S.Ty _ -> termNameFromSource term
|
||||
@ -323,7 +323,7 @@ parentContexts contexts = hsep $ either identifiableDoc annotatableDoc <$> conte
|
||||
toDoc :: Text -> Doc
|
||||
toDoc = string . toS
|
||||
|
||||
termToDiffInfo :: (StringConv leaf Text, DefaultFields fields) => Source Char -> SyntaxTerm leaf fields -> DiffInfo
|
||||
termToDiffInfo :: (StringConv leaf Text, DefaultFields fields) => Source -> SyntaxTerm leaf fields -> DiffInfo
|
||||
termToDiffInfo blob term = case unwrap term of
|
||||
S.Indexed children -> BranchInfo (termToDiffInfo' <$> children) (category $ extract term) BIndexed
|
||||
S.Fixed children -> BranchInfo (termToDiffInfo' <$> children) (category $ extract term) BFixed
|
||||
@ -340,7 +340,7 @@ termToDiffInfo blob term = case unwrap term of
|
||||
-- | For a DiffSummary without a parentAnnotation, we append a parentAnnotation with the first identifiable term.
|
||||
-- | For a DiffSummary with a parentAnnotation, we append the next annotatable term to the extant parentAnnotation.
|
||||
-- | If a DiffSummary already has a parentAnnotation, and a (grand) parentAnnotation, then we return the summary without modification.
|
||||
appendSummary :: (StringConv leaf Text, DefaultFields fields) => Source Char -> SyntaxTerm leaf fields -> DiffSummary DiffInfo -> DiffSummary DiffInfo
|
||||
appendSummary :: (StringConv leaf Text, DefaultFields fields) => Source -> SyntaxTerm leaf fields -> DiffSummary DiffInfo -> DiffSummary DiffInfo
|
||||
appendSummary source term summary =
|
||||
case (parentAnnotation summary, identifiable term, annotatable term) of
|
||||
([], Identifiable _, _) -> appendParentAnnotation Left
|
||||
|
||||
@ -50,7 +50,7 @@ diffFiles parse render sourceBlobs = do
|
||||
(_, _) ->
|
||||
runBothWith (diffTerms construct compareCategoryEq diffCostWithCachedTermCosts) terms
|
||||
areNullOids a b = (hasNullOid a, hasNullOid b)
|
||||
hasNullOid blob = oid blob == nullOid || null (source blob)
|
||||
hasNullOid blob = oid blob == nullOid || Source.null (source blob)
|
||||
construct (info :< syntax) = free (Free ((setCost <$> info <*> sumCost syntax) :< syntax))
|
||||
sumCost = fmap getSum . foldMap (fmap Sum . getCost)
|
||||
getCost diff = case runFree diff of
|
||||
|
||||
@ -8,7 +8,7 @@ import qualified Syntax as S
|
||||
import Term
|
||||
|
||||
termAssignment
|
||||
:: Source Char -- ^ The source of the term.
|
||||
:: Source -- ^ The source of the term.
|
||||
-> Category -- ^ The category for the term.
|
||||
-> [ SyntaxTerm Text '[Range, Category, SourceSpan] ] -- ^ The child nodes of the term.
|
||||
-> Maybe (S.Syntax Text (SyntaxTerm Text '[Range, Category, SourceSpan])) -- ^ The resulting term, in Maybe.
|
||||
|
||||
@ -8,7 +8,7 @@ import Term
|
||||
import qualified Syntax as S
|
||||
|
||||
termAssignment
|
||||
:: Source Char -- ^ The source of the term.
|
||||
:: Source -- ^ The source of the term.
|
||||
-> Category -- ^ The category for the term.
|
||||
-> [ SyntaxTerm Text '[Range, Category, SourceSpan] ] -- ^ The child nodes of the term.
|
||||
-> Maybe (S.Syntax Text (SyntaxTerm Text '[Range, Category, SourceSpan])) -- ^ The resulting term, in Maybe.
|
||||
|
||||
@ -9,7 +9,7 @@ import qualified Syntax as S
|
||||
import Term
|
||||
|
||||
termAssignment
|
||||
:: Source Char -- ^ The source of the term.
|
||||
:: Source -- ^ The source of the term.
|
||||
-> Category -- ^ The category for the term.
|
||||
-> [ SyntaxTerm Text '[Range, Category, SourceSpan] ] -- ^ The child nodes of the term.
|
||||
-> Maybe (S.Syntax Text (SyntaxTerm Text '[Range, Category, SourceSpan])) -- ^ The resulting term, in Maybe.
|
||||
|
||||
@ -7,7 +7,6 @@ import Data.Text
|
||||
import Info
|
||||
import Parser
|
||||
import Prologue
|
||||
import Range
|
||||
import Source
|
||||
import Syntax
|
||||
|
||||
|
||||
@ -4,13 +4,13 @@ module Language.Ruby where
|
||||
import Data.List (partition)
|
||||
import Info
|
||||
import Prologue
|
||||
import Source
|
||||
import Source hiding (null)
|
||||
import Language
|
||||
import qualified Syntax as S
|
||||
import Term
|
||||
|
||||
termAssignment
|
||||
:: Source Char -- ^ The source of the term.
|
||||
:: Source -- ^ The source of the term.
|
||||
-> Category -- ^ The category for the term.
|
||||
-> [ SyntaxTerm Text '[Range, Category, SourceSpan] ] -- ^ The child nodes of the term.
|
||||
-> Maybe (S.Syntax Text (SyntaxTerm Text '[Range, Category, SourceSpan])) -- ^ The resulting term, in Maybe.
|
||||
|
||||
14
src/Parse.hs
14
src/Parse.hs
@ -5,7 +5,7 @@ import Arguments
|
||||
import Category
|
||||
import Data.Aeson (ToJSON)
|
||||
import Data.Aeson.Encode.Pretty
|
||||
import qualified Data.ByteString.Char8 as B1
|
||||
import qualified Data.ByteString as B1
|
||||
import qualified Data.Text.ICU.Convert as Convert
|
||||
import qualified Data.Text.ICU.Detect as Detect
|
||||
import Data.Record
|
||||
@ -94,7 +94,7 @@ termCostDecorator :: (Foldable f, Functor f) => TermDecorator f a Cost
|
||||
termCostDecorator c = 1 + sum (cost <$> tailF c)
|
||||
|
||||
-- | Term decorator extracting the source text for a term.
|
||||
termSourceDecorator :: (HasField fields Range) => Source Char -> TermDecorator f fields SourceText
|
||||
termSourceDecorator :: (HasField fields Range) => Source -> TermDecorator f fields SourceText
|
||||
termSourceDecorator source c = SourceText . toText $ Source.slice range' source
|
||||
where range' = characterRange $ headF c
|
||||
|
||||
@ -104,24 +104,24 @@ lineByLineParser SourceBlob{..} = pure . cofree . root $ case foldl' annotateLea
|
||||
(leaves, _) -> cofree <$> leaves
|
||||
where
|
||||
lines = actualLines source
|
||||
root children = (Range 0 (length source) :. Program :. rangeToSourceSpan source (Range 0 (length source)) :. Nil) :< Indexed children
|
||||
root children = (sourceRange :. Program :. rangeToSourceSpan source sourceRange :. Nil) :< Indexed children
|
||||
sourceRange = Source.totalRange source
|
||||
leaf charIndex line = (Range charIndex (charIndex + T.length line) :. Program :. rangeToSourceSpan source (Range charIndex (charIndex + T.length line)) :. Nil) :< Leaf line
|
||||
annotateLeaves (accum, charIndex) line =
|
||||
(accum <> [ leaf charIndex (toText line) ] , charIndex + length line)
|
||||
toText = T.pack . Source.toString
|
||||
(accum <> [ leaf charIndex (Source.toText line) ] , charIndex + Source.length line)
|
||||
|
||||
-- | Return the parser that should be used for a given path.
|
||||
parserForFilepath :: FilePath -> Parser (Syntax Text) (Record '[Cost, Range, Category, SourceSpan])
|
||||
parserForFilepath path blob = decorateTerm termCostDecorator <$> parserForType (toS (takeExtension path)) blob
|
||||
|
||||
-- | Read the file and convert it to Unicode.
|
||||
readAndTranscodeFile :: FilePath -> IO (Source Char)
|
||||
readAndTranscodeFile :: FilePath -> IO Source
|
||||
readAndTranscodeFile path = do
|
||||
text <- B1.readFile path
|
||||
transcode text
|
||||
|
||||
-- | Transcode a file to a unicode source.
|
||||
transcode :: B1.ByteString -> IO (Source Char)
|
||||
transcode :: B1.ByteString -> IO Source
|
||||
transcode text = fromText <$> do
|
||||
match <- Detect.detectCharset text
|
||||
converter <- Convert.open match Nothing
|
||||
|
||||
13
src/Range.hs
13
src/Range.hs
@ -20,9 +20,16 @@ rangeAt a = Range a a
|
||||
rangeLength :: Range -> Int
|
||||
rangeLength range = end range - start range
|
||||
|
||||
-- | Return a range that covers the entire text.
|
||||
totalRange :: Foldable f => f a -> Range
|
||||
totalRange t = Range 0 $ length t
|
||||
-- | Offset a range by a constant delta.
|
||||
offsetRange :: Range -> Int -> Range
|
||||
offsetRange a b = Range (start a + b) (end a + b)
|
||||
|
||||
-- | Divide a range in two at the given coordinate.
|
||||
--
|
||||
-- Passing a coordinate that does not lie between start and end will result in one of the ranges being empty.
|
||||
divideRange :: Range -> Int -> (Range, Range)
|
||||
divideRange Range{..} at = (Range start divider, Range divider end)
|
||||
where divider = max (min end at) start
|
||||
|
||||
-- | Break a string down into words and sequences of punctuation. Return a list
|
||||
-- | strings with ranges, assuming that the first character in the string is
|
||||
|
||||
@ -10,27 +10,27 @@ import Data.Bifunctor.Join
|
||||
import Data.Functor.Both as Both
|
||||
import Data.List (span, unzip)
|
||||
import Data.Record
|
||||
import Data.String
|
||||
import Data.Text (pack)
|
||||
import qualified Data.Text as Text
|
||||
import Data.These
|
||||
import Diff
|
||||
import Patch
|
||||
import Prologue hiding (fst, snd)
|
||||
import Range
|
||||
import Renderer
|
||||
import Source hiding (break)
|
||||
import qualified Source
|
||||
import Source hiding (break, length, null)
|
||||
import SplitDiff
|
||||
|
||||
-- | Render a timed out file as a truncated diff.
|
||||
truncatePatch :: DiffArguments -> Both SourceBlob -> Text
|
||||
truncatePatch _ blobs = pack $ header blobs <> "#timed_out\nTruncating diff: timeout reached.\n"
|
||||
truncatePatch _ blobs = header blobs <> "#timed_out\nTruncating diff: timeout reached.\n"
|
||||
|
||||
-- | Render a diff in the traditional patch format.
|
||||
patch :: HasField fields Range => Renderer (Record fields)
|
||||
patch blobs diff = PatchOutput . pack $ case getLast (foldMap (Last . Just) string) of
|
||||
Just c | c /= '\n' -> string <> "\n\\ No newline at end of file\n"
|
||||
_ -> string
|
||||
where string = header blobs <> mconcat (showHunk blobs <$> hunks diff blobs)
|
||||
patch blobs diff = PatchOutput $ if not (Text.null text) && Text.last text /= '\n'
|
||||
then text <> "\n\\ No newline at end of file\n"
|
||||
else text
|
||||
where text = header blobs <> mconcat (showHunk blobs <$> hunks diff blobs)
|
||||
|
||||
-- | A hunk in a patch, including the offset, changes, and context.
|
||||
data Hunk a = Hunk { offset :: Both (Sum Int), changes :: [Change a], trailingContext :: [Join These a] }
|
||||
@ -53,9 +53,9 @@ 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 :: Functor f => HasField fields Range => Both SourceBlob -> Hunk (SplitDiff f (Record fields)) -> String
|
||||
showHunk :: Functor f => HasField fields Range => Both SourceBlob -> Hunk (SplitDiff f (Record fields)) -> Text
|
||||
showHunk blobs hunk = maybeOffsetHeader <>
|
||||
concat (showChange sources <$> changes hunk) <>
|
||||
mconcat (showChange sources <$> changes hunk) <>
|
||||
showLines (snd sources) ' ' (maybeSnd . runJoin <$> trailingContext hunk)
|
||||
where sources = source <$> blobs
|
||||
maybeOffsetHeader = if lengthA > 0 && lengthB > 0
|
||||
@ -66,45 +66,45 @@ 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 :: Functor f => HasField fields Range => Both (Source Char) -> Change (SplitDiff f (Record fields)) -> String
|
||||
showChange :: Functor f => HasField fields Range => Both Source -> Change (SplitDiff f (Record fields)) -> Text
|
||||
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 :: Functor f => HasField fields Range => Source Char -> Char -> [Maybe (SplitDiff f (Record fields))] -> String
|
||||
showLines :: Functor f => HasField fields Range => Source -> Char -> [Maybe (SplitDiff f (Record fields))] -> Text
|
||||
showLines source prefix lines = fromMaybe "" . mconcat $ fmap prepend . showLine source <$> lines
|
||||
where prepend "" = ""
|
||||
prepend source = prefix : source
|
||||
prepend source = Text.singleton prefix <> source
|
||||
|
||||
-- | Given a source, render a line to a 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 :: Functor f => HasField fields Range => Source -> Maybe (SplitDiff f (Record fields)) -> Maybe Text
|
||||
showLine source line | Just line <- line = Just . toText . (`slice` source) $ getRange line
|
||||
| otherwise = Nothing
|
||||
|
||||
-- | Returns the header given two source blobs and a hunk.
|
||||
header :: Both SourceBlob -> String
|
||||
header blobs = intercalate "\n" ([filepathHeader, fileModeHeader] <> maybeFilepaths) <> "\n"
|
||||
header :: Both SourceBlob -> Text
|
||||
header blobs = Text.intercalate "\n" ([filepathHeader, fileModeHeader] <> maybeFilepaths) <> "\n"
|
||||
where filepathHeader = "diff --git a/" <> pathA <> " b/" <> pathB
|
||||
fileModeHeader = case (modeA, modeB) of
|
||||
(Nothing, Just mode) -> intercalate "\n" [ "new file mode " <> modeToDigits mode, blobOidHeader ]
|
||||
(Just mode, Nothing) -> intercalate "\n" [ "deleted file mode " <> modeToDigits mode, blobOidHeader ]
|
||||
(Nothing, Just mode) -> Text.intercalate "\n" [ "new file mode " <> modeToDigits mode, blobOidHeader ]
|
||||
(Just mode, Nothing) -> Text.intercalate "\n" [ "deleted file mode " <> modeToDigits mode, blobOidHeader ]
|
||||
(Just mode, Just other) | mode == other -> "index " <> oidA <> ".." <> oidB <> " " <> modeToDigits mode
|
||||
(Just mode1, Just mode2) -> intercalate "\n" [
|
||||
(Just mode1, Just mode2) -> Text.intercalate "\n" [
|
||||
"old mode " <> modeToDigits mode1,
|
||||
"new mode " <> modeToDigits mode2,
|
||||
blobOidHeader
|
||||
]
|
||||
(Nothing, Nothing) -> ""
|
||||
blobOidHeader = "index " <> oidA <> ".." <> oidB
|
||||
modeHeader :: String -> Maybe SourceKind -> String -> String
|
||||
modeHeader :: Text -> Maybe SourceKind -> Text -> Text
|
||||
modeHeader ty maybeMode path = case maybeMode of
|
||||
Just _ -> ty <> "/" <> path
|
||||
Nothing -> "/dev/null"
|
||||
maybeFilepaths = if (nullOid == oidA && null (snd sources)) || (nullOid == oidB && null (fst sources)) then [] else [ beforeFilepath, afterFilepath ]
|
||||
maybeFilepaths = if (nullOid == oidA && Source.null (snd sources)) || (nullOid == oidB && Source.null (fst sources)) then [] else [ beforeFilepath, afterFilepath ]
|
||||
beforeFilepath = "--- " <> modeHeader "a" modeA pathA
|
||||
afterFilepath = "+++ " <> modeHeader "b" modeB pathB
|
||||
sources = source <$> blobs
|
||||
(pathA, pathB) = case runJoin $ path <$> blobs of
|
||||
(pathA, pathB) = case runJoin $ toS . path <$> blobs of
|
||||
("", path) -> (path, path)
|
||||
(path, "") -> (path, path)
|
||||
paths -> paths
|
||||
@ -119,7 +119,7 @@ emptyHunk = Hunk { offset = mempty, changes = [], trailingContext = [] }
|
||||
hunks :: HasField fields Range => SyntaxDiff leaf fields -> Both SourceBlob -> [Hunk (SplitSyntaxDiff leaf fields)]
|
||||
hunks _ blobs | sources <- source <$> blobs
|
||||
, sourcesEqual <- runBothWith (==) sources
|
||||
, sourcesNull <- runBothWith (&&) (null <$> sources)
|
||||
, sourcesNull <- runBothWith (&&) (Source.null <$> sources)
|
||||
, sourcesEqual || sourcesNull
|
||||
= [emptyHunk]
|
||||
hunks diff blobs = hunksInRows (pure 1) $ alignDiff (source <$> blobs) diff
|
||||
|
||||
@ -192,13 +192,13 @@ split blobs diff = SplitOutput . TL.toStrict . renderHtml
|
||||
data Cell a = Cell !Bool !Int !a
|
||||
|
||||
-- | Something that can be rendered as markup with reference to some source.
|
||||
data Renderable a = Renderable !(Source Char) !a
|
||||
data Renderable a = Renderable !Source !a
|
||||
|
||||
contentElements :: (Foldable t, ToMarkup f) => Source Char -> Range -> t (f, Range) -> [Markup]
|
||||
contentElements :: (Foldable t, ToMarkup f) => Source -> Range -> t (f, Range) -> [Markup]
|
||||
contentElements source range children = let (elements, next) = foldr' (markupForContextAndChild source) ([], end range) children in
|
||||
text (toText (slice (Range (start range) (max next (start range))) source)) : elements
|
||||
|
||||
markupForContextAndChild :: ToMarkup f => Source Char -> (f, Range) -> ([Markup], Int) -> ([Markup], Int)
|
||||
markupForContextAndChild :: ToMarkup f => Source -> (f, Range) -> ([Markup], Int) -> ([Markup], Int)
|
||||
markupForContextAndChild source (child, range) (rows, next) = (toMarkup child : text (toText (slice (Range (end range) next) source)) : rows, start range)
|
||||
|
||||
wrapIn :: (Markup -> Markup) -> Markup -> Markup
|
||||
@ -213,7 +213,7 @@ wrapIn f p = f p
|
||||
|
||||
instance (ToMarkup f, HasField fields Category, HasField fields Range) => ToMarkup (Renderable (SyntaxTermF leaf fields (f, Range))) where
|
||||
toMarkup (Renderable source (info :< syntax)) = classifyMarkup (category info) $ case syntax of
|
||||
Leaf _ -> span . string . toString $ slice (characterRange info) source
|
||||
Leaf _ -> span . text . toText $ slice (characterRange info) source
|
||||
_ -> ul . mconcat $ wrapIn li <$> contentElements source (characterRange info) (toList syntax)
|
||||
|
||||
instance (HasField fields Category, HasField fields Range) => ToMarkup (Renderable (SyntaxTerm leaf fields)) where
|
||||
|
||||
@ -6,7 +6,7 @@ import Renderer
|
||||
import Data.Record
|
||||
import DiffSummary
|
||||
import Data.Map as Map hiding (null)
|
||||
import Source
|
||||
import Source hiding (null)
|
||||
import Data.Aeson
|
||||
import Data.List as List
|
||||
|
||||
|
||||
@ -9,10 +9,11 @@ import Data.Record
|
||||
import Diff
|
||||
import Info
|
||||
import Prologue
|
||||
import Range
|
||||
import qualified Data.List as List
|
||||
import qualified Data.Map as Map hiding (null)
|
||||
import Renderer
|
||||
import Source
|
||||
import Source hiding (null)
|
||||
import Syntax as S
|
||||
import Term
|
||||
import Patch
|
||||
@ -71,7 +72,7 @@ diffTOC blobs diff = do
|
||||
removeDupes [] = []
|
||||
removeDupes xs = (fmap unsafeHead . List.groupBy (\a b -> parentInfo a == parentInfo b)) xs
|
||||
|
||||
diffToTOCSummaries :: (StringConv leaf Text, DefaultFields fields) => Both (Source Char) -> SyntaxDiff leaf fields -> [TOCSummary DiffInfo]
|
||||
diffToTOCSummaries :: (StringConv leaf Text, DefaultFields fields) => Both Source -> SyntaxDiff leaf fields -> [TOCSummary DiffInfo]
|
||||
diffToTOCSummaries sources = para $ \diff ->
|
||||
let
|
||||
diff' = free (Prologue.fst <$> diff)
|
||||
@ -105,17 +106,17 @@ toLeafInfos' :: DiffInfo -> [DiffInfo]
|
||||
toLeafInfos' BranchInfo{..} = branches >>= toLeafInfos'
|
||||
toLeafInfos' leaf = [leaf]
|
||||
|
||||
mapToInSummarizable :: DefaultFields fields => Both (Source Char) -> SyntaxDiff leaf fields -> [TOCSummary DiffInfo] -> [TOCSummary DiffInfo]
|
||||
mapToInSummarizable :: forall leaf fields. DefaultFields fields => Both Source -> SyntaxDiff leaf fields -> [TOCSummary DiffInfo] -> [TOCSummary DiffInfo]
|
||||
mapToInSummarizable sources diff children = case (beforeTerm diff, afterTerm diff) of
|
||||
(_, Just diff') -> mapToInSummarizable' (Both.snd sources) diff' <$> children
|
||||
(Just diff', _) -> mapToInSummarizable' (Both.fst sources) diff' <$> children
|
||||
(Nothing, Nothing) -> []
|
||||
where
|
||||
mapToInSummarizable' :: DefaultFields fields => Source Char -> SyntaxTerm leaf fields -> TOCSummary DiffInfo -> TOCSummary DiffInfo
|
||||
mapToInSummarizable' :: Source -> SyntaxTerm leaf fields -> TOCSummary DiffInfo -> TOCSummary DiffInfo
|
||||
mapToInSummarizable' source term summary =
|
||||
case (parentInfo summary, summarizable term) of
|
||||
(NotSummarizable, SummarizableTerm _) ->
|
||||
summary { parentInfo = InSummarizable (category (extract term)) (toTermName source term) (Info.sourceSpan (extract term)) }
|
||||
summary { parentInfo = InSummarizable (category (extract term)) (toTermName 0 source term) (Info.sourceSpan (extract term)) }
|
||||
(_, _) -> summary
|
||||
|
||||
summarizable :: ComonadCofree (Syntax t) w => w a -> SummarizableTerm (w a)
|
||||
@ -137,26 +138,28 @@ toJSONSummaries TOCSummary{..} = case afterOrBefore summaryPatch of
|
||||
NotSummarizable -> []
|
||||
_ -> pure $ JSONSummary parentInfo
|
||||
|
||||
termToDiffInfo :: (StringConv leaf Text, DefaultFields fields) => Source Char -> SyntaxTerm leaf fields -> DiffInfo
|
||||
termToDiffInfo blob term = case unwrap term of
|
||||
termToDiffInfo :: forall leaf fields. (StringConv leaf Text, DefaultFields fields) => Source -> SyntaxTerm leaf fields -> DiffInfo
|
||||
termToDiffInfo source term = case unwrap term of
|
||||
S.Indexed children -> BranchInfo (termToDiffInfo' <$> children) (category $ extract term)
|
||||
S.Fixed children -> BranchInfo (termToDiffInfo' <$> children) (category $ extract term)
|
||||
S.AnonymousFunction _ _ -> LeafInfo C.AnonymousFunction (toTermName' term) (getField $ extract term)
|
||||
S.Commented cs leaf -> BranchInfo (termToDiffInfo' <$> cs <> maybeToList leaf) (category $ extract term)
|
||||
S.ParseError _ -> ErrorInfo (getField $ extract term) (toTermName' term)
|
||||
_ -> toLeafInfo term
|
||||
where toTermName' = toTermName blob
|
||||
termToDiffInfo' = termToDiffInfo blob
|
||||
toLeafInfo term = LeafInfo (category $ extract term) (toTermName' term) (getField $ extract term)
|
||||
where
|
||||
toTermName' = toTermName 0 source
|
||||
termToDiffInfo' = termToDiffInfo source
|
||||
toLeafInfo term = LeafInfo (category $ extract term) (toTermName' term) (getField $ extract term)
|
||||
|
||||
toTermName :: forall leaf fields. DefaultFields fields => Source Char -> SyntaxTerm leaf fields -> Text
|
||||
toTermName source term = case unwrap term of
|
||||
toTermName :: forall leaf fields. DefaultFields fields => Int -> Source -> SyntaxTerm leaf fields -> Text
|
||||
toTermName parentOffset parentSource term = case unwrap term of
|
||||
S.Function identifier _ _ _ -> toTermName' identifier
|
||||
S.Method identifier Nothing _ _ _ -> toTermName' identifier
|
||||
S.Method identifier (Just receiver) _ _ _ -> toTermName' receiver <> "." <> toTermName' identifier
|
||||
_ -> termNameFromSource term
|
||||
_ -> toText source
|
||||
where
|
||||
toTermName' = toTermName source
|
||||
termNameFromSource term = termNameFromRange (range term)
|
||||
termNameFromRange range = toText $ Source.slice range source
|
||||
source = Source.slice (offsetRange (range term) (negate parentOffset)) parentSource
|
||||
offset = start (range term)
|
||||
toTermName' :: SyntaxTerm leaf fields -> Text
|
||||
toTermName' = toTermName offset source
|
||||
range = characterRange . extract
|
||||
|
||||
@ -161,7 +161,7 @@ getSourceBlob path sha = do
|
||||
Nothing -> pure (mempty, mempty, Nothing)
|
||||
Just (BlobEntry entryOid entryKind) -> do
|
||||
blob <- lookupBlob entryOid
|
||||
let (BlobString s) = blobContents blob
|
||||
s <- blobToByteString blob
|
||||
let oid = renderObjOid $ blobOid blob
|
||||
pure (s, oid, Just entryKind)
|
||||
s <- liftIO $ transcode bytestring
|
||||
|
||||
106
src/Source.hs
106
src/Source.hs
@ -2,30 +2,30 @@
|
||||
{-# OPTIONS_GHC -funbox-strict-fields #-}
|
||||
module Source where
|
||||
|
||||
import Prologue hiding (uncons)
|
||||
import Data.Text (unpack, pack)
|
||||
import Data.String
|
||||
import qualified Data.Vector as Vector
|
||||
import Prologue
|
||||
import qualified Data.Text as Text
|
||||
import Data.Text.Listable
|
||||
import Numeric
|
||||
import Range
|
||||
import SourceSpan
|
||||
import Test.LeanCheck
|
||||
|
||||
-- | The source, oid, path, and Maybe SourceKind of a blob in a Git repo.
|
||||
data SourceBlob = SourceBlob { source :: Source Char, oid :: String, path :: FilePath, blobKind :: Maybe SourceKind }
|
||||
data SourceBlob = SourceBlob { source :: Source, oid :: Text, path :: FilePath, blobKind :: Maybe SourceKind }
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- | The contents of a source file, backed by a vector for efficient slicing.
|
||||
newtype Source a = Source { getVector :: Vector.Vector a }
|
||||
deriving (Eq, Show, Foldable, Functor, Traversable)
|
||||
-- | The contents of a source file, represented as Text.
|
||||
newtype Source = Source { sourceText :: Text }
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | The kind of a blob, along with it's file mode.
|
||||
data SourceKind = PlainBlob Word32 | ExecutableBlob Word32 | SymlinkBlob Word32
|
||||
deriving (Show, Eq)
|
||||
|
||||
modeToDigits :: SourceKind -> String
|
||||
modeToDigits (PlainBlob mode) = showOct mode ""
|
||||
modeToDigits (ExecutableBlob mode) = showOct mode ""
|
||||
modeToDigits (SymlinkBlob mode) = showOct mode ""
|
||||
modeToDigits :: SourceKind -> Text
|
||||
modeToDigits (PlainBlob mode) = toS $ showOct mode ""
|
||||
modeToDigits (ExecutableBlob mode) = toS $ showOct mode ""
|
||||
modeToDigits (SymlinkBlob mode) = toS $ showOct mode ""
|
||||
|
||||
|
||||
-- | The default plain blob mode
|
||||
@ -35,7 +35,7 @@ defaultPlainBlob = PlainBlob 0o100644
|
||||
emptySourceBlob :: FilePath -> SourceBlob
|
||||
emptySourceBlob filepath = SourceBlob (Source.fromList "") Source.nullOid filepath Nothing
|
||||
|
||||
sourceBlob :: Source Char -> FilePath -> SourceBlob
|
||||
sourceBlob :: Source -> FilePath -> SourceBlob
|
||||
sourceBlob source filepath = SourceBlob source Source.nullOid filepath (Just defaultPlainBlob)
|
||||
|
||||
-- | Map blobs with Nothing blobKind to empty blobs.
|
||||
@ -44,74 +44,82 @@ idOrEmptySourceBlob blob = if isNothing (blobKind blob)
|
||||
then blob { oid = nullOid, blobKind = Nothing }
|
||||
else blob
|
||||
|
||||
nullOid :: String
|
||||
nullOid :: Text
|
||||
nullOid = "0000000000000000000000000000000000000000"
|
||||
|
||||
-- | Return a Source from a list of items.
|
||||
fromList :: [a] -> Source a
|
||||
fromList = Source . Vector.fromList
|
||||
fromList :: [Char] -> Source
|
||||
fromList = Source . Text.pack
|
||||
|
||||
-- | Return a Source of Chars from a Text.
|
||||
fromText :: Text -> Source Char
|
||||
fromText = Source . Vector.fromList . unpack
|
||||
fromText :: Text -> Source
|
||||
fromText = Source
|
||||
|
||||
-- | Return a Source that contains a slice of the given Source.
|
||||
slice :: Range -> Source a -> Source a
|
||||
slice range = Source . Vector.slice (start range) (rangeLength range) . getVector
|
||||
|
||||
-- | Return a String with the contents of the Source.
|
||||
toString :: Source Char -> String
|
||||
toString = toList
|
||||
slice :: Range -> Source -> Source
|
||||
slice range = Source . take . drop . sourceText
|
||||
where drop = Text.drop (start range)
|
||||
take = Text.take (rangeLength range)
|
||||
|
||||
-- | Return a text with the contents of the Source.
|
||||
toText :: Source Char -> Text
|
||||
toText = pack . toList
|
||||
toText :: Source -> Text
|
||||
toText = sourceText
|
||||
|
||||
-- | Return the item at the given index.
|
||||
at :: Source a -> Int -> a
|
||||
at = (Vector.!) . getVector
|
||||
|
||||
-- | Remove the first item and return it with the rest of the source.
|
||||
uncons :: Source a -> Maybe (a, Source a)
|
||||
uncons (Source vector) = if null vector then Nothing else Just (Vector.head vector, Source $ Vector.tail vector)
|
||||
at :: Source -> Int -> Char
|
||||
at = Text.index . sourceText
|
||||
|
||||
-- | Split the source into the longest prefix of elements that do not satisfy the predicate and the rest without copying.
|
||||
break :: (a -> Bool) -> Source a -> (Source a, Source a)
|
||||
break predicate (Source vector) = let (start, remainder) = Vector.break predicate vector in (Source start, Source remainder)
|
||||
break :: (Char -> Bool) -> Source -> (Source, Source)
|
||||
break predicate (Source text) = let (start, remainder) = Text.break predicate text in (Source start, Source remainder)
|
||||
|
||||
-- | Split the contents of the source after newlines.
|
||||
actualLines :: Source Char -> [Source Char]
|
||||
actualLines source | null source = [ source ]
|
||||
actualLines source = case Source.break (== '\n') source of
|
||||
(l, lines') -> case uncons lines' of
|
||||
Nothing -> [ l ]
|
||||
Just (_, lines') -> (l <> fromList "\n") : actualLines lines'
|
||||
actualLines :: Source -> [Source]
|
||||
actualLines = fmap Source . actualLines' . sourceText
|
||||
where actualLines' text
|
||||
| Text.null text = [ text ]
|
||||
| otherwise = case Text.break (== '\n') text of
|
||||
(l, lines') -> case Text.uncons lines' of
|
||||
Nothing -> [ l ]
|
||||
Just (_, lines') -> (l <> Text.singleton '\n') : actualLines' lines'
|
||||
|
||||
-- | Compute the line ranges within a given range of a string.
|
||||
actualLineRanges :: Range -> Source Char -> [Range]
|
||||
actualLineRanges :: Range -> Source -> [Range]
|
||||
actualLineRanges range = drop 1 . scanl toRange (Range (start range) (start range)) . actualLines . slice range
|
||||
where toRange previous string = Range (end previous) $ end previous + length string
|
||||
where toRange previous string = Range (end previous) $ end previous + Text.length (sourceText string)
|
||||
|
||||
-- | Compute the character range given a Source and a SourceSpan.
|
||||
sourceSpanToRange :: Source Char -> SourceSpan -> Range
|
||||
sourceSpanToRange :: Source -> SourceSpan -> Range
|
||||
sourceSpanToRange source SourceSpan{..} = Range start end
|
||||
where start = sumLengths leadingRanges + column spanStart
|
||||
end = start + sumLengths (take (line spanEnd - line spanStart) remainingRanges) + (column spanEnd - column spanStart)
|
||||
(leadingRanges, remainingRanges) = splitAt (line spanStart) (actualLineRanges (totalRange source) source)
|
||||
(leadingRanges, remainingRanges) = splitAt (line spanStart) (actualLineRanges (Source.totalRange source) source)
|
||||
sumLengths = sum . fmap (\ Range{..} -> end - start)
|
||||
|
||||
rangeToSourceSpan :: Source Char -> Range -> SourceSpan
|
||||
-- | Return a range that covers the entire text.
|
||||
totalRange :: Source -> Range
|
||||
totalRange = Range 0 . Text.length . sourceText
|
||||
|
||||
rangeToSourceSpan :: Source -> Range -> SourceSpan
|
||||
rangeToSourceSpan source range@Range{} = SourceSpan startPos endPos
|
||||
where startPos = maybe (SourcePos 1 1) (toStartPos 1) (head lineRanges)
|
||||
endPos = toEndPos (length lineRanges) (fromMaybe (rangeAt 0) (snd <$> unsnoc lineRanges))
|
||||
endPos = toEndPos (Prologue.length lineRanges) (fromMaybe (rangeAt 0) (snd <$> unsnoc lineRanges))
|
||||
lineRanges = actualLineRanges range source
|
||||
toStartPos line range = SourcePos line (start range)
|
||||
toEndPos line range = SourcePos line (end range)
|
||||
|
||||
length :: Source -> Int
|
||||
length = Text.length . sourceText
|
||||
|
||||
instance Semigroup (Source a) where
|
||||
Source a <> Source b = Source (a Vector.++ b)
|
||||
null :: Source -> Bool
|
||||
null = Text.null . sourceText
|
||||
|
||||
instance Monoid (Source a) where
|
||||
instance Semigroup Source where
|
||||
Source a <> Source b = Source (a <> b)
|
||||
|
||||
instance Monoid Source where
|
||||
mempty = fromList []
|
||||
mappend = (<>)
|
||||
|
||||
instance Listable Source where
|
||||
tiers = (Source . unListableText) `mapT` tiers
|
||||
|
||||
@ -17,7 +17,8 @@ import Range
|
||||
import Source
|
||||
import qualified Syntax
|
||||
import Foreign
|
||||
import Foreign.C.String
|
||||
import Foreign.C.String (peekCString)
|
||||
import Data.Text.Foreign (withCStringLen)
|
||||
import qualified Syntax as S
|
||||
import Term
|
||||
import Text.Parser.TreeSitter hiding (Language(..))
|
||||
@ -30,50 +31,56 @@ treeSitterParser :: Language -> Ptr TS.Language -> Parser (Syntax.Syntax Text) (
|
||||
treeSitterParser language grammar blob = do
|
||||
document <- ts_document_new
|
||||
ts_document_set_language document grammar
|
||||
withCString (toString $ source blob) (\source -> do
|
||||
ts_document_set_input_string document source
|
||||
withCStringLen (toText (source blob)) $ \ (source, len) -> do
|
||||
ts_document_set_input_string_with_length document source len
|
||||
ts_document_parse document
|
||||
term <- documentToTerm language document blob
|
||||
ts_document_free document
|
||||
pure term)
|
||||
pure term
|
||||
|
||||
|
||||
-- | Return a parser for a tree sitter language & document.
|
||||
documentToTerm :: Language -> Ptr Document -> Parser (Syntax.Syntax Text) (Record '[Range, Category, SourceSpan])
|
||||
documentToTerm language document SourceBlob{..} = alloca $ \ root -> do
|
||||
ts_document_root_node_p document root
|
||||
toTerm root
|
||||
where toTerm node = do
|
||||
toTerm root (totalRange source) source
|
||||
where toTerm node range source = do
|
||||
name <- ts_node_p_name node document
|
||||
name <- peekCString name
|
||||
count <- ts_node_p_named_child_count node
|
||||
children <- filter isNonEmpty <$> traverse (alloca . getChild node) (take (fromIntegral count) [0..])
|
||||
|
||||
let range = Range { start = fromIntegral $ ts_node_p_start_char node, end = fromIntegral $ ts_node_p_end_char node }
|
||||
let getChild getter parentNode n childNode = do
|
||||
_ <- getter parentNode n childNode
|
||||
let childRange = nodeRange childNode
|
||||
toTerm childNode childRange (slice (offsetRange childRange (negate (start range))) source)
|
||||
|
||||
children <- filter isNonEmpty <$> traverse (alloca . getChild ts_node_p_named_child node) (take (fromIntegral count) [0..])
|
||||
|
||||
let startPos = SourcePos (1 + (fromIntegral $! ts_node_p_start_point_row node)) (1 + (fromIntegral $! ts_node_p_start_point_column node))
|
||||
let endPos = SourcePos (1 + (fromIntegral $! ts_node_p_end_point_row node)) (1 + (fromIntegral $! ts_node_p_end_point_column node))
|
||||
let sourceSpan = SourceSpan { spanStart = startPos , spanEnd = endPos }
|
||||
|
||||
allChildrenCount <- ts_node_p_child_count node
|
||||
let allChildren = filter isNonEmpty <$> traverse (alloca . getUnnamedChild node) (take (fromIntegral allChildrenCount) [0..])
|
||||
let allChildren = filter isNonEmpty <$> traverse (alloca . getChild ts_node_p_child node) (take (fromIntegral allChildrenCount) [0..])
|
||||
|
||||
-- Note: The strict application here is semantically important.
|
||||
-- Without it, we may not evaluate the value until after we’ve exited
|
||||
-- the scope that `node` was allocated within, meaning `alloca` will
|
||||
-- free it & other stack data may overwrite it.
|
||||
range `seq` sourceSpan `seq` assignTerm language (slice range source) (range :. categoryForLanguageProductionName language (toS name) :. sourceSpan :. Nil) children allChildren
|
||||
getChild node n out = ts_node_p_named_child node n out >> toTerm out
|
||||
{-# INLINE getChild #-}
|
||||
getUnnamedChild node n out = ts_node_p_child node n out >> toTerm out
|
||||
{-# INLINE getUnnamedChild #-}
|
||||
isNonEmpty child = category (extract child) /= Empty
|
||||
range `seq` sourceSpan `seq` assignTerm language source (range :. categoryForLanguageProductionName language (toS name) :. sourceSpan :. Nil) children allChildren
|
||||
|
||||
assignTerm :: Language -> Source Char -> Record '[Range, Category, SourceSpan] -> [ SyntaxTerm Text '[ Range, Category, SourceSpan ] ] -> IO [ SyntaxTerm Text '[ Range, Category, SourceSpan ] ] -> IO (SyntaxTerm Text '[ Range, Category, SourceSpan ])
|
||||
isNonEmpty :: HasField fields Category => SyntaxTerm Text fields -> Bool
|
||||
isNonEmpty = (/= Empty) . category . extract
|
||||
|
||||
nodeRange :: Ptr Node -> Range
|
||||
nodeRange node = Range { start = fromIntegral (ts_node_p_start_char node), end = fromIntegral (ts_node_p_end_char node) }
|
||||
|
||||
assignTerm :: Language -> Source -> Record '[Range, Category, SourceSpan] -> [ SyntaxTerm Text '[ Range, Category, SourceSpan ] ] -> IO [ SyntaxTerm Text '[ Range, Category, SourceSpan ] ] -> IO (SyntaxTerm Text '[ Range, Category, SourceSpan ])
|
||||
assignTerm language source annotation children allChildren =
|
||||
cofree . (annotation :<) <$> case assignTermByLanguage language source (category annotation) children of
|
||||
Just a -> pure a
|
||||
_ -> defaultTermAssignment source (category annotation) children allChildren
|
||||
where assignTermByLanguage :: Language -> Source Char -> Category -> [ SyntaxTerm Text '[ Range, Category, SourceSpan ] ] -> Maybe (S.Syntax Text (SyntaxTerm Text '[ Range, Category, SourceSpan ]))
|
||||
where assignTermByLanguage :: Language -> Source -> Category -> [ SyntaxTerm Text '[ Range, Category, SourceSpan ] ] -> Maybe (S.Syntax Text (SyntaxTerm Text '[ Range, Category, SourceSpan ]))
|
||||
assignTermByLanguage = \case
|
||||
JavaScript -> JS.termAssignment
|
||||
C -> C.termAssignment
|
||||
@ -81,7 +88,7 @@ assignTerm language source annotation children allChildren =
|
||||
Ruby -> Ruby.termAssignment
|
||||
_ -> \ _ _ _ -> Nothing
|
||||
|
||||
defaultTermAssignment :: Source Char -> Category -> [ SyntaxTerm Text '[Range, Category, SourceSpan] ] -> IO [ SyntaxTerm Text '[Range, Category, SourceSpan] ] -> IO (S.Syntax Text (SyntaxTerm Text '[Range, Category, SourceSpan]))
|
||||
defaultTermAssignment :: Source -> Category -> [ SyntaxTerm Text '[Range, Category, SourceSpan] ] -> IO [ SyntaxTerm Text '[Range, Category, SourceSpan] ] -> IO (S.Syntax Text (SyntaxTerm Text '[Range, Category, SourceSpan]))
|
||||
defaultTermAssignment source category children allChildren
|
||||
| category `elem` operatorCategories = S.Operator <$> allChildren
|
||||
| otherwise = pure $! case (category, children) of
|
||||
|
||||
@ -11,7 +11,7 @@ import Data.Functor.Listable
|
||||
import Data.List (nub)
|
||||
import Data.Monoid hiding ((<>))
|
||||
import Data.Record
|
||||
import Data.String
|
||||
import qualified Data.Text as Text
|
||||
import Data.These
|
||||
import Patch
|
||||
import Prologue hiding (fst, snd)
|
||||
@ -31,7 +31,7 @@ spec :: Spec
|
||||
spec = parallel $ do
|
||||
describe "alignBranch" $ do
|
||||
it "produces symmetrical context" $
|
||||
alignBranch getRange ([] :: [Join These (SplitDiff (Syntax String) (Record '[Range]))]) (both [Range 0 2, Range 2 4] [Range 0 2, Range 2 4]) `shouldBe`
|
||||
alignBranch getRange ([] :: [Join These (SplitDiff (Syntax Text) (Record '[Range]))]) (both [Range 0 2, Range 2 4] [Range 0 2, Range 2 4]) `shouldBe`
|
||||
[ Join (These (Range 0 2, [])
|
||||
(Range 0 2, []))
|
||||
, Join (These (Range 2 4, [])
|
||||
@ -39,7 +39,7 @@ spec = parallel $ do
|
||||
]
|
||||
|
||||
it "produces asymmetrical context" $
|
||||
alignBranch getRange ([] :: [Join These (SplitDiff (Syntax String) (Record '[Range]))]) (both [Range 0 2, Range 2 4] [Range 0 1]) `shouldBe`
|
||||
alignBranch getRange ([] :: [Join These (SplitDiff (Syntax Text) (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, []))
|
||||
@ -61,13 +61,13 @@ spec = parallel $ do
|
||||
|
||||
describe "alignDiff" $ do
|
||||
it "aligns identical branches on a single line" $
|
||||
let sources = both (Source.fromList "[ foo ]") (Source.fromList "[ foo ]") in
|
||||
let sources = both (Source.fromText "[ foo ]") (Source.fromText "[ foo ]") in
|
||||
align sources (pure (info 0 7) `branch` [ pure (info 2 5) `leaf` "foo" ]) `shouldBe` prettyDiff sources
|
||||
[ Join (These (info 0 7 `branch` [ info 2 5 `leaf` "foo" ])
|
||||
(info 0 7 `branch` [ info 2 5 `leaf` "foo" ])) ]
|
||||
|
||||
it "aligns identical branches spanning multiple lines" $
|
||||
let sources = both (Source.fromList "[\nfoo\n]") (Source.fromList "[\nfoo\n]") in
|
||||
let sources = both (Source.fromText "[\nfoo\n]") (Source.fromText "[\nfoo\n]") in
|
||||
align sources (pure (info 0 7) `branch` [ pure (info 2 5) `leaf` "foo" ]) `shouldBe` prettyDiff sources
|
||||
[ Join (These (info 0 2 `branch` [])
|
||||
(info 0 2 `branch` []))
|
||||
@ -78,7 +78,7 @@ spec = parallel $ do
|
||||
]
|
||||
|
||||
it "aligns reformatted branches" $
|
||||
let sources = both (Source.fromList "[ foo ]") (Source.fromList "[\nfoo\n]") in
|
||||
let sources = both (Source.fromText "[ foo ]") (Source.fromText "[\nfoo\n]") in
|
||||
align sources (pure (info 0 7) `branch` [ pure (info 2 5) `leaf` "foo" ]) `shouldBe` prettyDiff sources
|
||||
[ Join (That (info 0 2 `branch` []))
|
||||
, Join (These (info 0 7 `branch` [ info 2 5 `leaf` "foo" ])
|
||||
@ -87,7 +87,7 @@ spec = parallel $ do
|
||||
]
|
||||
|
||||
it "aligns nodes following reformatted branches" $
|
||||
let sources = both (Source.fromList "[ foo ]\nbar\n") (Source.fromList "[\nfoo\n]\nbar\n") in
|
||||
let sources = both (Source.fromText "[ foo ]\nbar\n") (Source.fromText "[\nfoo\n]\nbar\n") in
|
||||
align sources (pure (info 0 12) `branch` [ pure (info 0 7) `branch` [ pure (info 2 5) `leaf` "foo" ], pure (info 8 11) `leaf` "bar" ]) `shouldBe` prettyDiff sources
|
||||
[ Join (That (info 0 2 `branch` [ info 0 2 `branch` [] ]))
|
||||
, Join (These (info 0 8 `branch` [ info 0 7 `branch` [ info 2 5 `leaf` "foo" ] ])
|
||||
@ -100,12 +100,12 @@ spec = parallel $ do
|
||||
]
|
||||
|
||||
it "aligns identical branches with multiple children on the same line" $
|
||||
let sources = pure (Source.fromList "[ foo, bar ]") in
|
||||
let sources = pure (Source.fromText "[ foo, bar ]") in
|
||||
align sources (pure (info 0 12) `branch` [ pure (info 2 5) `leaf` "foo", pure (info 7 10) `leaf` "bar" ]) `shouldBe` prettyDiff sources
|
||||
[ Join (runBothWith These (pure (info 0 12 `branch` [ info 2 5 `leaf` "foo", info 7 10 `leaf` "bar" ])) ) ]
|
||||
|
||||
it "aligns insertions" $
|
||||
let sources = both (Source.fromList "a") (Source.fromList "a\nb") in
|
||||
let sources = both (Source.fromText "a") (Source.fromText "a\nb") in
|
||||
align sources (both (info 0 1) (info 0 3) `branch` [ pure (info 0 1) `leaf` "a", insert (info 2 3 `leaf` "b") ]) `shouldBe` prettyDiff sources
|
||||
[ Join (These (info 0 1 `branch` [ info 0 1 `leaf` "a" ])
|
||||
(info 0 2 `branch` [ info 0 1 `leaf` "a" ]))
|
||||
@ -113,19 +113,19 @@ spec = parallel $ do
|
||||
]
|
||||
|
||||
it "aligns total insertions" $
|
||||
let sources = both (Source.fromList "") (Source.fromList "a") in
|
||||
let sources = both (Source.fromText "") (Source.fromText "a") in
|
||||
align sources (insert (info 0 1 `leaf` "a")) `shouldBe` prettyDiff sources
|
||||
[ Join (That (insert (info 0 1 `leaf` "a"))) ]
|
||||
|
||||
it "aligns insertions into empty branches" $
|
||||
let sources = both (Source.fromList "[ ]") (Source.fromList "[a]") in
|
||||
let sources = both (Source.fromText "[ ]") (Source.fromText "[a]") in
|
||||
align sources (pure (info 0 3) `branch` [ insert (info 1 2 `leaf` "a") ]) `shouldBe` prettyDiff sources
|
||||
[ Join (That (info 0 3 `branch` [ insert (info 1 2 `leaf` "a") ]))
|
||||
, Join (This (info 0 3 `branch` []))
|
||||
]
|
||||
|
||||
it "aligns symmetrically following insertions" $
|
||||
let sources = both (Source.fromList "a\nc") (Source.fromList "a\nb\nc") in
|
||||
let sources = both (Source.fromText "a\nc") (Source.fromText "a\nb\nc") in
|
||||
align sources (both (info 0 3) (info 0 5) `branch` [ pure (info 0 1) `leaf` "a", insert (info 2 3 `leaf` "b"), both (info 2 3) (info 4 5) `leaf` "c" ])
|
||||
`shouldBe` prettyDiff sources
|
||||
[ Join (These (info 0 2 `branch` [ info 0 1 `leaf` "a" ])
|
||||
@ -136,13 +136,13 @@ spec = parallel $ do
|
||||
]
|
||||
|
||||
it "symmetrical nodes force the alignment of asymmetrical nodes on both sides" $
|
||||
let sources = both (Source.fromList "[ a, b ]") (Source.fromList "[ b, c ]") in
|
||||
let sources = both (Source.fromText "[ a, b ]") (Source.fromText "[ b, c ]") in
|
||||
align sources (pure (info 0 8) `branch` [ delete (info 2 3 `leaf` "a"), both (info 5 6) (info 2 3) `leaf` "b", insert (info 5 6 `leaf` "c") ]) `shouldBe` prettyDiff sources
|
||||
[ Join (These (info 0 8 `branch` [ delete (info 2 3 `leaf` "a"), info 5 6 `leaf` "b" ])
|
||||
(info 0 8 `branch` [ info 2 3 `leaf` "b", insert (info 5 6 `leaf` "c") ])) ]
|
||||
|
||||
it "when one of two symmetrical nodes must be split, splits the latter" $
|
||||
let sources = both (Source.fromList "[ a, b ]") (Source.fromList "[ a\n, b\n]") in
|
||||
let sources = both (Source.fromText "[ a, b ]") (Source.fromText "[ a\n, b\n]") in
|
||||
align sources (both (info 0 8) (info 0 9) `branch` [ pure (info 2 3) `leaf` "a", both (info 5 6) (info 6 7) `leaf` "b" ]) `shouldBe` prettyDiff sources
|
||||
[ Join (These (info 0 8 `branch` [ info 2 3 `leaf` "a", info 5 6 `leaf` "b" ])
|
||||
(info 0 4 `branch` [ info 2 3 `leaf` "a" ]))
|
||||
@ -151,14 +151,14 @@ spec = parallel $ do
|
||||
]
|
||||
|
||||
it "aligns deletions before insertions" $
|
||||
let sources = both (Source.fromList "[ a ]") (Source.fromList "[ b ]") in
|
||||
let sources = both (Source.fromText "[ a ]") (Source.fromText "[ b ]") in
|
||||
align sources (pure (info 0 5) `branch` [ delete (info 2 3 `leaf` "a"), insert (info 2 3 `leaf` "b") ]) `shouldBe` prettyDiff sources
|
||||
[ Join (This (info 0 5 `branch` [ delete (info 2 3 `leaf` "a") ]))
|
||||
, Join (That (info 0 5 `branch` [ insert (info 2 3 `leaf` "b") ]))
|
||||
]
|
||||
|
||||
it "aligns context-only lines symmetrically" $
|
||||
let sources = both (Source.fromList "[\n a\n,\n b\n]") (Source.fromList "[\n a, b\n\n\n]") in
|
||||
let sources = both (Source.fromText "[\n a\n,\n b\n]") (Source.fromText "[\n a, b\n\n\n]") in
|
||||
align sources (both (info 0 13) (info 0 12) `branch` [ pure (info 4 5) `leaf` "a", both (info 10 11) (info 7 8) `leaf` "b" ]) `shouldBe` prettyDiff sources
|
||||
[ Join (These (info 0 2 `branch` [])
|
||||
(info 0 2 `branch` []))
|
||||
@ -173,7 +173,7 @@ spec = parallel $ do
|
||||
]
|
||||
|
||||
it "aligns asymmetrical nodes preceding their symmetrical siblings conservatively" $
|
||||
let sources = both (Source.fromList "[ b, c ]") (Source.fromList "[ a\n, c\n]") in
|
||||
let sources = both (Source.fromText "[ b, c ]") (Source.fromText "[ a\n, c\n]") in
|
||||
align sources (both (info 0 8) (info 0 9) `branch` [ insert (info 2 3 `leaf` "a"), delete (info 2 3 `leaf` "b"), both (info 5 6) (info 6 7) `leaf` "c" ]) `shouldBe` prettyDiff sources
|
||||
[ Join (That (info 0 4 `branch` [ insert (info 2 3 `leaf` "a") ]))
|
||||
, Join (These (info 0 8 `branch` [ delete (info 2 3 `leaf` "b"), info 5 6 `leaf` "c" ])
|
||||
@ -182,7 +182,7 @@ spec = parallel $ do
|
||||
]
|
||||
|
||||
it "aligns symmetrical reformatted nodes" $
|
||||
let sources = both (Source.fromList "a [ b ]\nc") (Source.fromList "a [\nb\n]\nc") in
|
||||
let sources = both (Source.fromText "a [ b ]\nc") (Source.fromText "a [\nb\n]\nc") in
|
||||
align sources (pure (info 0 9) `branch` [ pure (info 0 1) `leaf` "a", pure (info 2 7) `branch` [ pure (info 4 5) `leaf` "b" ], pure (info 8 9) `leaf` "c" ]) `shouldBe` prettyDiff sources
|
||||
[ Join (These (info 0 8 `branch` [ info 0 1 `leaf` "a", info 2 7 `branch` [ info 4 5 `leaf` "b" ] ])
|
||||
(info 0 4 `branch` [ info 0 1 `leaf` "a", info 2 4 `branch` [] ]))
|
||||
@ -197,39 +197,39 @@ spec = parallel $ do
|
||||
\ xs -> counts (numberedRows (unListableF <$> xs :: [Join These Char])) `shouldBe` length . catMaybes <$> Join (unalign (runJoin . unListableF <$> xs))
|
||||
|
||||
data BranchElement
|
||||
= Child String (Join These String)
|
||||
| Margin (Join These String)
|
||||
= Child Text (Join These Text)
|
||||
| Margin (Join These Text)
|
||||
deriving Show
|
||||
|
||||
branchElementKey :: BranchElement -> Maybe String
|
||||
branchElementKey :: BranchElement -> Maybe Text
|
||||
branchElementKey (Child key _) = Just key
|
||||
branchElementKey _ = Nothing
|
||||
|
||||
toAlignBranchInputs :: [BranchElement] -> (Both (Source.Source Char), [Join These (String, Range)], Both [Range])
|
||||
toAlignBranchInputs :: [BranchElement] -> (Both Source.Source, [Join These (Text, Range)], Both [Range])
|
||||
toAlignBranchInputs elements = (sources, join . (`evalState` both 0 0) . traverse go $ elements, ranges)
|
||||
where go :: BranchElement -> State (Both Int) [Join These (String, Range)]
|
||||
where go :: BranchElement -> State (Both Int) [Join These (Text, Range)]
|
||||
go child@(Child key _) = do
|
||||
lines <- traverse (\ (Child _ contents) -> do
|
||||
prev <- get
|
||||
let next = (+) <$> prev <*> modifyJoin (fromThese 0 0) (length <$> contents)
|
||||
let next = (+) <$> prev <*> modifyJoin (fromThese 0 0) (Text.length <$> contents)
|
||||
put next
|
||||
pure $! modifyJoin (runBothWith bimap (const <$> (Range <$> prev <*> next))) contents) (alignBranchElement child)
|
||||
pure $! fmap ((,) key) <$> lines
|
||||
go (Margin contents) = do
|
||||
prev <- get
|
||||
put $ (+) <$> prev <*> modifyJoin (fromThese 0 0) (length <$> contents)
|
||||
put $ (+) <$> prev <*> modifyJoin (fromThese 0 0) (Text.length <$> contents)
|
||||
pure []
|
||||
alignBranchElement element = case element of
|
||||
Child key contents -> Child key <$> joinCrosswalk lines contents
|
||||
Margin contents -> Margin <$> joinCrosswalk lines contents
|
||||
where lines = fmap toList . Source.actualLines . Source.fromList
|
||||
sources = foldMap Source.fromList <$> bothContents elements
|
||||
ranges = fmap (filter (\ (Range start end) -> start /= end)) $ Source.actualLineRanges <$> (totalRange <$> sources) <*> sources
|
||||
where lines = fmap Source.sourceText . Source.actualLines . Source.fromText
|
||||
sources = foldMap Source.fromText <$> bothContents elements
|
||||
ranges = fmap (filter (\ (Range start end) -> start /= end)) $ Source.actualLineRanges <$> (Source.totalRange <$> sources) <*> sources
|
||||
bothContents = foldMap (modifyJoin (fromThese [] []) . fmap (:[]) . branchElementContents)
|
||||
branchElementContents (Child _ contents) = contents
|
||||
branchElementContents (Margin contents) = contents
|
||||
|
||||
keysOfAlignedChildren :: [Join These (Range, [(String, Range)])] -> [String]
|
||||
keysOfAlignedChildren :: [Join These (Range, [(Text, Range)])] -> [Text]
|
||||
keysOfAlignedChildren lines = lines >>= these identity identity (<>) . runJoin . fmap (fmap Prologue.fst . Prologue.snd)
|
||||
|
||||
joinCrosswalk :: Bicrosswalk p => Align f => (a -> f b) -> Join p a -> f (Join p b)
|
||||
@ -237,10 +237,10 @@ joinCrosswalk f = fmap Join . bicrosswalk f f . runJoin
|
||||
|
||||
instance Listable BranchElement where
|
||||
tiers = oneof [ (\ key -> Child key `mapT` joinTheseOf (contents key)) `concatMapT` key
|
||||
, Margin `mapT` joinTheseOf (pure `mapT` padding '-') ]
|
||||
where key = pure `mapT` [['a'..'z'] <> ['A'..'Z'] <> ['0'..'9']]
|
||||
contents key = (wrap key . pure) `mapT` padding '*'
|
||||
wrap key contents = "(" <> key <> contents <> ")" :: String
|
||||
, Margin `mapT` joinTheseOf (Text.singleton `mapT` padding '-') ]
|
||||
where key = Text.singleton `mapT` [['a'..'z'] <> ['A'..'Z'] <> ['0'..'9']]
|
||||
contents key = (wrap key . Text.singleton) `mapT` padding '*'
|
||||
wrap key contents = "(" <> key <> contents <> ")" :: Text
|
||||
padding :: Char -> [Tier Char]
|
||||
padding char = frequency [ (10, [[char]])
|
||||
, (1, [['\n']]) ]
|
||||
@ -256,16 +256,16 @@ instance Listable BranchElement where
|
||||
counts :: [Join These (Int, a)] -> Both Int
|
||||
counts numbered = fromMaybe 0 . getLast . mconcat . fmap Last <$> Join (unalign (runJoin . fmap Prologue.fst <$> numbered))
|
||||
|
||||
align :: Both (Source.Source Char) -> ConstructibleFree (Patch (Term (Syntax String) (Record '[Range]))) (Both (Record '[Range])) -> PrettyDiff (SplitDiff (Syntax String) (Record '[Range]))
|
||||
align :: Both Source.Source -> ConstructibleFree (Patch (Term (Syntax Text) (Record '[Range]))) (Both (Record '[Range])) -> PrettyDiff (SplitDiff (Syntax Text) (Record '[Range]))
|
||||
align sources = PrettyDiff sources . fmap (fmap (getRange &&& identity)) . alignDiff sources . deconstruct
|
||||
|
||||
info :: Int -> Int -> Record '[Range]
|
||||
info start end = Range start end :. Nil
|
||||
|
||||
prettyDiff :: Both (Source.Source Char) -> [Join These (ConstructibleFree (SplitPatch (Term (Syntax String) (Record '[Range]))) (Record '[Range]))] -> PrettyDiff (SplitDiff (Syntax String) (Record '[Range]))
|
||||
prettyDiff :: Both Source.Source -> [Join These (ConstructibleFree (SplitPatch (Term (Syntax Text) (Record '[Range]))) (Record '[Range]))] -> PrettyDiff (SplitDiff (Syntax Text) (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)] }
|
||||
data PrettyDiff a = PrettyDiff { unPrettySources :: Both Source.Source, unPrettyLines :: [Join These (Range, a)] }
|
||||
deriving Eq
|
||||
|
||||
instance Show (PrettyDiff a) where
|
||||
@ -273,22 +273,22 @@ instance Show (PrettyDiff a) where
|
||||
where prettyPrinted = showLine (maximum (0 : (maximum . fmap length <$> shownLines))) <$> shownLines >>= ('\n':)
|
||||
shownLines = catMaybes $ toBoth <$> lines
|
||||
showLine n line = uncurry ((<>) . (++ " | ")) (fromThese (replicate n ' ') (replicate n ' ') (runJoin (pad n <$> line)))
|
||||
showDiff (range, _) = filter (/= '\n') . toList . Source.slice range
|
||||
showDiff (range, _) = filter (/= '\n') . Text.unpack . Source.sourceText . Source.slice range
|
||||
pad n string = (<>) (take n string) (replicate (max 0 (n - length string)) ' ')
|
||||
toBoth them = showDiff <$> them `applyThese` modifyJoin (uncurry These) sources
|
||||
|
||||
newtype ConstructibleFree patch annotation = ConstructibleFree { deconstruct :: Free (CofreeF (Syntax String) annotation) patch }
|
||||
newtype ConstructibleFree patch annotation = ConstructibleFree { deconstruct :: Free (CofreeF (Syntax Text) annotation) patch }
|
||||
|
||||
|
||||
class PatchConstructible p where
|
||||
insert :: Term (Syntax String) (Record '[Range]) -> p
|
||||
delete :: Term (Syntax String) (Record '[Range]) -> p
|
||||
insert :: Term (Syntax Text) (Record '[Range]) -> p
|
||||
delete :: Term (Syntax Text) (Record '[Range]) -> p
|
||||
|
||||
instance PatchConstructible (Patch (Term (Syntax String) (Record '[Range]))) where
|
||||
instance PatchConstructible (Patch (Term (Syntax Text) (Record '[Range]))) where
|
||||
insert = Insert
|
||||
delete = Delete
|
||||
|
||||
instance PatchConstructible (SplitPatch (Term (Syntax String) (Record '[Range]))) where
|
||||
instance PatchConstructible (SplitPatch (Term (Syntax Text) (Record '[Range]))) where
|
||||
insert = SplitInsert
|
||||
delete = SplitDelete
|
||||
|
||||
@ -297,13 +297,13 @@ instance PatchConstructible patch => PatchConstructible (ConstructibleFree patch
|
||||
delete = ConstructibleFree . pure . delete
|
||||
|
||||
class SyntaxConstructible s where
|
||||
leaf :: annotation -> String -> s annotation
|
||||
leaf :: annotation -> Text -> s annotation
|
||||
branch :: annotation -> [s annotation] -> s annotation
|
||||
|
||||
instance SyntaxConstructible (ConstructibleFree patch) where
|
||||
leaf info = ConstructibleFree . free . Free . (info :<) . Leaf
|
||||
branch info = ConstructibleFree . free . Free . (info :<) . Indexed . fmap deconstruct
|
||||
|
||||
instance SyntaxConstructible (Cofree (Syntax String)) where
|
||||
instance SyntaxConstructible (Cofree (Syntax Text)) where
|
||||
info `leaf` value = cofree $ info :< Leaf value
|
||||
info `branch` children = cofree $ info :< Indexed children
|
||||
|
||||
@ -86,7 +86,7 @@ testDiff renderer paths diff matcher = do
|
||||
matcher actual (Just expected)
|
||||
where diffFiles' sources parser = diffFiles parser renderer (sourceBlobs sources paths)
|
||||
parser = parserWithCost <$> runBothWith (<|>) paths
|
||||
sourceBlobs :: Both (Maybe (S.Source Char)) -> Both (Maybe FilePath) -> Both S.SourceBlob
|
||||
sourceBlobs :: Both (Maybe (S.Source)) -> Both (Maybe FilePath) -> Both S.SourceBlob
|
||||
sourceBlobs sources paths = case runJoin paths of
|
||||
(Nothing, Nothing) -> Join (S.emptySourceBlob "", S.emptySourceBlob "")
|
||||
(Nothing, Just filepath) -> Join (S.emptySourceBlob "", S.sourceBlob (unsafeFromJust $ snd sources) filepath)
|
||||
|
||||
@ -84,7 +84,7 @@ spec = parallel $ do
|
||||
let listOfLeaves = foldMap extractLeaves (join $ toList <$> branchPatches)
|
||||
listOfDiffLeaves = foldMap extractDiffLeaves (diffPatches >>= toList)
|
||||
in
|
||||
length listOfLeaves `shouldBe` length listOfDiffLeaves
|
||||
Prologue.length listOfLeaves `shouldBe` Prologue.length listOfDiffLeaves
|
||||
|
||||
isIndexedOrFixed :: Patch (Term (Syntax a) annotation) -> Bool
|
||||
isIndexedOrFixed = any (isIndexedOrFixed' . unwrap)
|
||||
|
||||
@ -1,22 +1,22 @@
|
||||
module Source.Spec where
|
||||
|
||||
import qualified Data.Text as Text
|
||||
import qualified Prelude
|
||||
import Prologue
|
||||
import Range
|
||||
import Source
|
||||
import SourceSpan
|
||||
import Test.Hspec
|
||||
import Test.Hspec.QuickCheck
|
||||
import Test.Hspec.LeanCheck
|
||||
|
||||
spec :: Spec
|
||||
spec = parallel $ do
|
||||
describe "actualLineRanges" $ do
|
||||
prop "produces 1 more range than there are newlines" $
|
||||
\ s -> length (actualLineRanges (totalRange s) (fromList s)) `shouldBe` succ (length (filter (== '\n') s))
|
||||
\ source -> Prologue.length (actualLineRanges (totalRange source) source) `shouldBe` succ (Text.count "\n" (sourceText source))
|
||||
|
||||
prop "produces exhaustive ranges" $
|
||||
\ s -> let source = fromList s in
|
||||
foldMap (`slice` source) (actualLineRanges (totalRange s) source) `shouldBe` source
|
||||
\ source -> foldMap (`slice` source) (actualLineRanges (totalRange source) source) `shouldBe` source
|
||||
|
||||
describe "sourceSpanToRange" $ do
|
||||
prop "computes single-line ranges" $
|
||||
@ -40,8 +40,8 @@ spec = parallel $ do
|
||||
prop "covers multiple lines" $
|
||||
\ n -> totalSpan (fromList (intersperse '\n' (replicate n '*'))) `shouldBe` SourceSpan (SourcePos 0 0) (SourcePos (max 0 (pred n)) (if n > 0 then 1 else 0))
|
||||
|
||||
totalSpan :: Source Char -> SourceSpan
|
||||
totalSpan source = SourceSpan (SourcePos 0 0) (SourcePos (pred (length ranges)) (end lastRange - start lastRange))
|
||||
totalSpan :: Source -> SourceSpan
|
||||
totalSpan source = SourceSpan (SourcePos 0 0) (SourcePos (pred (Prologue.length ranges)) (end lastRange - start lastRange))
|
||||
where ranges = actualLineRanges (totalRange source) source
|
||||
lastRange = Prelude.last ranges
|
||||
|
||||
|
||||
2
vendor/haskell-tree-sitter
vendored
2
vendor/haskell-tree-sitter
vendored
@ -1 +1 @@
|
||||
Subproject commit 8116ff5ec37cae106ed78771a9676057ad702b80
|
||||
Subproject commit b4575e8083ea210eec2de50862cce3fbb2c97b00
|
||||
Loading…
Reference in New Issue
Block a user