mirror of
https://github.com/github/semantic.git
synced 2024-12-29 01:42:43 +03:00
Merge pull request #249 from github/sunshine-lollipops-and-rainbows-everywhere
Sunshine lollipops and rainbows everywhere
This commit is contained in:
Josh Vera
commit
69a0d33ffe
51
app/Unified.hs
Normal file
51
app/Unified.hs
Normal file
@ -0,0 +1,51 @@
|
||||
module Unified (unified) where
|
||||
|
||||
import Diff
|
||||
import Patch
|
||||
import Syntax
|
||||
import Term
|
||||
import Control.Arrow
|
||||
import Control.Monad.Free
|
||||
import Control.Comonad.Cofree
|
||||
import Data.List hiding (foldl)
|
||||
import qualified Data.Map as Map
|
||||
import Rainbow
|
||||
|
||||
unified :: Diff a Info -> String -> String -> IO ByteString
|
||||
unified diff before after = do
|
||||
renderer <- byteStringMakerFromEnvironment
|
||||
return . mconcat . chunksToByteStrings renderer . pure . fst $ iter g mapped where
|
||||
mapped = fmap (unifiedPatch &&& range) diff
|
||||
g (Annotated (_, info) syntax) = f info syntax
|
||||
f (Info range _) (Leaf _) = (substring range after, Just range)
|
||||
f (Info range _) (Indexed i) = (unifiedRange range i after, Just range)
|
||||
f (Info range _) (Fixed f) = (unifiedRange range f after, Just range)
|
||||
f (Info range _) (Keyed k) = (unifiedRange range (sort $ snd <$> Map.toList k) after, Just range)
|
||||
|
||||
unifiedPatch :: Patch (Term a Info) -> Chunk String
|
||||
unifiedPatch patch = (beforeChunk & fore red & bold) <> (afterChunk & fore green & bold) where
|
||||
beforeChunk = maybe (chunk "") (change "-" . unifiedTerm before) $ Patch.before patch
|
||||
afterChunk = maybe (chunk "") (change "+" . unifiedTerm after) $ Patch.after patch
|
||||
|
||||
unifiedTerm :: String -> Term a Info -> Chunk String
|
||||
unifiedTerm source term = fst $ cata f term
|
||||
|
||||
unifiedRange :: Range -> [(Chunk String, Maybe Range)] -> String -> Chunk String
|
||||
unifiedRange range children source = out <> substring Range { start = previous, end = end range } after where
|
||||
(out, previous) = foldl accumulateContext (chunk "", start range) children
|
||||
accumulateContext (out, previous) (child, Just range) = (mconcat [ out, substring Range { start = previous, end = start range } source, child ], end range)
|
||||
accumulateContext (out, previous) (child, _) = (out <> child, previous)
|
||||
|
||||
substring :: Range -> String -> Chunk String
|
||||
substring range = chunk . take (end range) . drop (start range)
|
||||
|
||||
range :: Patch (Term a Info) -> Maybe Range
|
||||
range patch = range . extract <$> after patch where
|
||||
extract (annotation :< _) = annotation
|
||||
range (Info range _) = range
|
||||
|
||||
change :: String -> Chunk String -> Chunk String
|
||||
change bound content = mconcat [ chunk "{", chunk bound, content, chunk bound, chunk "}" ]
|
||||
|
||||
instance Ord Range where
|
||||
a <= b = start a <= start b
|
||||
@ -22,13 +22,11 @@ library
|
||||
, SES
|
||||
, Categorizable
|
||||
, Term
|
||||
, Unified
|
||||
, Console
|
||||
build-depends: base >= 4.8 && < 5
|
||||
, containers
|
||||
, free
|
||||
default-language: Haskell2010
|
||||
default-extensions: DeriveFunctor, FlexibleInstances, DeriveFoldable, DeriveTraversable
|
||||
default-extensions: DeriveFunctor, FlexibleInstances, DeriveFoldable, DeriveTraversable
|
||||
|
||||
executable semantic-diff-exe
|
||||
hs-source-dirs: app
|
||||
@ -38,9 +36,11 @@ executable semantic-diff-exe
|
||||
, containers
|
||||
, free
|
||||
, semantic-diff
|
||||
, rainbow
|
||||
default-language: Haskell2010
|
||||
extra-libraries: bridge
|
||||
extra-lib-dirs: prototype/External/tree-sitter/out/Release, prototype/External/tree-sitter-c, .
|
||||
other-modules: Unified
|
||||
extra-libraries: bridge
|
||||
extra-lib-dirs: prototype/External/tree-sitter/out/Release, prototype/External/tree-sitter-c, .
|
||||
|
||||
test-suite semantic-diff-test
|
||||
type: exitcode-stdio-1.0
|
||||
|
||||
@ -1,43 +0,0 @@
|
||||
module Console where
|
||||
|
||||
import Data.Char
|
||||
|
||||
data Colour = Black | Red | Green | Yellow | Blue | Purple | Cyan | White
|
||||
deriving Bounded
|
||||
|
||||
instance Enum Colour where
|
||||
fromEnum Black = 30
|
||||
fromEnum Red = 31
|
||||
fromEnum Green = 32
|
||||
fromEnum Yellow = 33
|
||||
fromEnum Blue = 34
|
||||
fromEnum Purple = 35
|
||||
fromEnum Cyan = 36
|
||||
fromEnum White = 37
|
||||
|
||||
toEnum 30 = Black
|
||||
toEnum 31 = Red
|
||||
toEnum 32 = Green
|
||||
toEnum 33 = Yellow
|
||||
toEnum 34 = Blue
|
||||
toEnum 35 = Purple
|
||||
toEnum 36 = Cyan
|
||||
toEnum 37 = White
|
||||
toEnum _ = error "unknown colour code"
|
||||
|
||||
data Style = Normal | Bold | Underline
|
||||
deriving Bounded
|
||||
|
||||
instance Enum Style where
|
||||
fromEnum Normal = 0
|
||||
fromEnum Bold = 1
|
||||
fromEnum Underline = 4
|
||||
|
||||
toEnum 0 = Normal
|
||||
toEnum 1 = Bold
|
||||
toEnum 4 = Underline
|
||||
|
||||
data Attribute = Attribute { colour :: Colour, style :: Style }
|
||||
|
||||
applyAttribute :: Attribute -> String -> String
|
||||
applyAttribute attribute string = "\x001b[" ++ [ chr . fromEnum $ style attribute ] ++ ";" ++ [ chr . fromEnum $ colour attribute ] ++ "m" ++ string ++ "\x001b[0m"
|
||||
@ -1,53 +0,0 @@
|
||||
module Unified (unified) where
|
||||
|
||||
import Console
|
||||
import Diff
|
||||
import Patch
|
||||
import Syntax
|
||||
import Term
|
||||
import Control.Arrow
|
||||
import Control.Monad.Free
|
||||
import Control.Comonad.Cofree
|
||||
import Data.List hiding (foldl)
|
||||
import qualified Data.Map as Map
|
||||
|
||||
unified :: Diff a Info -> String -> String -> String
|
||||
unified diff before after =
|
||||
fst $ iter g mapped where
|
||||
mapped = fmap (unifiedPatch &&& range) diff
|
||||
g (Annotated (_, info) syntax) = f info syntax
|
||||
f (Info range _) (Leaf _) = (substring range after, Just range)
|
||||
f (Info range _) (Indexed i) = (unifiedRange range i after, Just range)
|
||||
f (Info range _) (Fixed f) = (unifiedRange range f after, Just range)
|
||||
f (Info range _) (Keyed k) = (unifiedRange range (sort $ snd <$> Map.toList k) after, Just range)
|
||||
|
||||
unifiedPatch :: Patch (Term a Info) -> String
|
||||
unifiedPatch patch = before ++ after where
|
||||
before = maybe "" (applyAttribute beforeAttribute . change "-" . unifiedTerm before) $ Patch.before patch
|
||||
after = maybe "" (applyAttribute afterAttribute . change "+" . unifiedTerm after) $ Patch.after patch
|
||||
|
||||
beforeAttribute = Attribute { colour = Red, style = Bold }
|
||||
afterAttribute = Attribute { colour = Green, style = Bold }
|
||||
|
||||
unifiedTerm :: String -> Term a Info -> String
|
||||
unifiedTerm source term = fst $ cata f term
|
||||
|
||||
unifiedRange :: Range -> [(String, Maybe Range)] -> String -> String
|
||||
unifiedRange range children source = out ++ substring Range { start = previous, end = end range } after where
|
||||
(out, previous) = foldl accumulateContext ("", start range) children
|
||||
accumulateContext (out, previous) (child, Just range) = (out ++ substring Range { start = previous, end = start range } source ++ child, end range)
|
||||
accumulateContext (out, previous) (child, _) = (out ++ child, previous)
|
||||
|
||||
substring :: Range -> String -> String
|
||||
substring range = take (end range) . drop (start range)
|
||||
|
||||
range :: Patch (Term a Info) -> Maybe Range
|
||||
range patch = range . extract <$> after patch where
|
||||
extract (annotation :< _) = annotation
|
||||
range (Info range _) = range
|
||||
|
||||
change :: String -> String -> String
|
||||
change bound content = "{" ++ bound ++ content ++ bound ++ "}"
|
||||
|
||||
instance Ord Range where
|
||||
a <= b = start a <= start b
|
||||
Loading…
Reference in New Issue
Block a user