github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-25 07:55:12 +03:00
Code Issues Projects Releases Wiki Activity

Merge branch 'master' into ghc-8.2.1

Browse Source
This commit is contained in:
Rob Rix 2017-07-28 10:17:29 -04:00
commit 232b345fda
11 changed files with 107 additions and 82 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
languages/c/Setup.hs
View File

@ -1,2 +0,0 @@
import Distribution.Simple
main = defaultMain

25
languages/c/c.cabal
View File

@ -1,25 +0,0 @@
name: c
version: 0.1.0
synopsis: tree-sitter c language bindings
description: Please see README.md
homepage: https://github.com/github/semantic-diff#readme
author: semantic-code
maintainer: tclem@github.com
copyright: 2017 GitHub
category: Web
build-type: Simple
-- extra-source-files:
cabal-version: >=1.10
library
hs-source-dirs: src
exposed-modules: Text.Parser.TreeSitter.C
build-depends: base >= 4.7 && < 5
, haskell-tree-sitter
default-language: Haskell2010
default-extensions: FlexibleInstances, OverloadedStrings, NoImplicitPrelude, RecordWildCards
c-sources: vendor/tree-sitter-c/src/parser.c
source-repository head
type: git
location: https://github.com/github/semantic-diff

6
languages/c/src/Text/Parser/TreeSitter/C.hs
View File

@ -1,6 +0,0 @@
module Text.Parser.TreeSitter.C where
import Text.Parser.TreeSitter
import Foreign.Ptr
foreign import ccall unsafe "vendor/tree-sitter-c/src/parser.c tree_sitter_c" tree_sitter_c :: Ptr Language

1
languages/c/vendor/tree-sitter-c vendored

@ -1 +0,0 @@
Subproject commit debe919f846e2f28dd4700e0cf39889e5fd5994a

2
semantic-diff.cabal
View File

@ -45,7 +45,6 @@ library
, Info
, Interpreter
, Language
, Language.C
, Language.Markdown
, Language.Markdown.Syntax
, Language.Go
@ -116,7 +115,6 @@ library
, these
, time
, haskell-tree-sitter
, c
, go
, ruby
, typescript

43
src/Data/Syntax/Assignment.hs
View File

@ -119,11 +119,11 @@ data AssignmentF ast grammar a where
Project :: HasCallStack => (forall x. Base ast x -> a) -> AssignmentF ast grammar a
Source :: HasCallStack => AssignmentF ast grammar ByteString
Children :: HasCallStack => Assignment ast grammar a -> AssignmentF ast grammar a
Choose :: HasCallStack => IntMap.IntMap a -> AssignmentF ast grammar a
Choose :: HasCallStack => IntMap.IntMap a -> Maybe a -> AssignmentF ast grammar a
Many :: HasCallStack => Assignment ast grammar a -> AssignmentF ast grammar [a]
Alt :: HasCallStack => a -> a -> AssignmentF ast grammar a
Throw :: HasCallStack => Error grammar -> AssignmentF ast grammar a
Catch :: HasCallStack => a -> (Error grammar -> a) -> AssignmentF ast grammar a
Catch :: HasCallStack => Assignment ast grammar a -> (Error grammar -> Assignment ast grammar a) -> AssignmentF ast grammar a
-- | Zero-width production of the current location.
--
@ -141,7 +141,7 @@ project projection = Project projection `Then` return
--
-- Since this is zero-width, care must be taken not to repeat it without chaining on other rules. I.e. @many (symbol A *> b)@ is fine, but @many (symbol A)@ is not.
symbol :: (Enum grammar, Eq grammar, HasCallStack) => grammar -> Assignment ast grammar (Record Location)
symbol s = withFrozenCallStack $ Choose (IntMap.singleton (fromEnum s) ()) `Then` (const location)
symbol s = withFrozenCallStack $ Choose (IntMap.singleton (fromEnum s) ()) Nothing `Then` (const location)
-- | A rule to produce a node’s source as a ByteString.
source :: HasCallStack => Assignment ast grammar ByteString
@ -288,20 +288,21 @@ runAssignment toNode source = (\ assignment state -> go assignment state >>= req
Children child -> do
(a, state') <- go child state { stateNodes = toList node } >>= requireExhaustive
yield a (advance state' { stateNodes = stateNodes state })
Choose choices | Just choice <- IntMap.lookup (fromEnum (nodeSymbol (toNode node))) choices -> yield choice state
Choose choices _ | Just choice <- IntMap.lookup (fromEnum (nodeSymbol (toNode node))) choices -> yield choice state
_ -> anywhere (Just node)
anywhere node = case assignment of
Location -> yield (Info.Range (stateOffset state) (stateOffset state) :. Info.Span (statePos state) (statePos state) :. Nil) state
Choose _ (Just atEnd) -> yield atEnd state
Many rule -> uncurry yield (runMany rule state)
Alt a b -> yield a state `catchError` (\ err -> yield b state { stateError = Just err })
Throw e -> Left e
Catch during handler -> yield during state `catchError` (flip yield state . handler)
Catch during handler -> (go during state `catchError` (flip go state . handler)) >>= uncurry yield
_ -> Left (maybe (Error (statePos state) expectedSymbols Nothing) (nodeError expectedSymbols . toNode) node)
state | _:_ <- expectedSymbols, all ((== Regular) . symbolType) expectedSymbols = dropAnonymous initialState
| otherwise = initialState
expectedSymbols | Choose choices <- assignment = (toEnum :: Int -> grammar) <$> IntMap.keys choices
expectedSymbols | Choose choices _ <- assignment = (toEnum :: Int -> grammar) <$> IntMap.keys choices
| otherwise = []
runMany :: Assignment ast grammar result -> State ast grammar -> ([result], State ast grammar)
@ -343,15 +344,29 @@ makeState = State 0 (Info.Pos 1 1) Nothing 0
instance Enum grammar => Alternative (Assignment ast grammar) where
empty :: HasCallStack => Assignment ast grammar a
empty = Choose mempty `Then` return
empty = Choose mempty Nothing `Then` return
(<|>) :: HasCallStack => Assignment ast grammar a -> Assignment ast grammar a -> Assignment ast grammar a
Return a <|> _ = Return a
a <|> b | Just c <- (liftA2 (<>) `on` choices) a b = Choose c `Then` identity
| otherwise = wrap $ Alt a b
(Throw err `Then` continue) <|> _ = Throw err `Then` continue
(Children l `Then` continueL) <|> (Children r `Then` continueR) = Children (Left <$> l <|> Right <$> r) `Then` either continueL continueR
(Location `Then` continueL) <|> (Location `Then` continueR) = Location `Then` uncurry (<|>) . (continueL &&& continueR)
(Source `Then` continueL) <|> (Source `Then` continueR) = Source `Then` uncurry (<|>) . (continueL &&& continueR)
l <|> r | Just c <- (liftA2 (IntMap.unionWith (<|>)) `on` choices) l r = Choose c (atEnd l <|> atEnd r) `Then` identity
| otherwise = wrap $ Alt l r
where choices :: Assignment ast grammar a -> Maybe (IntMap (Assignment ast grammar a))
choices (Choose choices `Then` continue) = Just (continue <$> choices)
choices (Many rule `Then` continue) = fmap (const (Many rule `Then` continue)) <$> choices rule
choices (Choose choices _ `Then` continue) = Just (continue <$> choices)
choices (Many rule `Then` continue) = ((Many rule `Then` continue) <$) <$> choices rule
choices (Catch during handler `Then` continue) = ((Catch during handler `Then` continue) <$) <$> choices during
choices (Throw _ `Then` _) = Just IntMap.empty
choices (Return _) = Just IntMap.empty
choices _ = Nothing
atEnd :: Assignment ast grammar a -> Maybe (Assignment ast grammar a)
atEnd (Choose _ atEnd `Then` continue) = continue <$> atEnd
atEnd (Many rule `Then` continue) = Just (Many rule `Then` continue)
atEnd (Catch during handler `Then` continue) = Just (Catch during handler `Then` continue)
atEnd (Throw err `Then` continue) = Just (Throw err `Then` continue)
atEnd (Return a) = Just (Return a)
atEnd _ = Nothing
many :: HasCallStack => Assignment ast grammar a -> Assignment ast grammar [a]
many a = Many a `Then` return
@ -361,15 +376,15 @@ instance Show grammar => Show1 (AssignmentF ast grammar) where
Project projection -> showsUnaryWith (const (const (showChar '_'))) "Project" d projection
Source -> showString "Source" . showChar ' ' . sp d ""
Children a -> showsUnaryWith (liftShowsPrec sp sl) "Children" d a
Choose choices -> showsUnaryWith (liftShowsPrec (liftShowsPrec sp sl) (liftShowList sp sl)) "Choose" d (IntMap.toList choices)
Choose choices atEnd -> showsBinaryWith (liftShowsPrec (liftShowsPrec sp sl) (liftShowList sp sl)) (liftShowsPrec sp sl) "Choose" d (IntMap.toList choices) atEnd
Many a -> showsUnaryWith (liftShowsPrec (\ d a -> sp d [a]) (sl . pure)) "Many" d a
Alt a b -> showsBinaryWith sp sp "Alt" d a b
Throw e -> showsUnaryWith showsPrec "Throw" d e
Catch during handler -> showsBinaryWith sp (const (const (showChar '_'))) "Catch" d during handler
Catch during handler -> showsBinaryWith (liftShowsPrec sp sl) (const (const (showChar '_'))) "Catch" d during handler
instance MonadError (Error grammar) (Assignment ast grammar) where
throwError :: HasCallStack => Error grammar -> Assignment ast grammar a
throwError error = withFrozenCallStack $ Throw error `Then` return
catchError :: HasCallStack => Assignment ast grammar a -> (Error grammar -> Assignment ast grammar a) -> Assignment ast grammar a
catchError during handler = withFrozenCallStack $ Catch during handler `Then` identity
catchError during handler = withFrozenCallStack $ Catch during handler `Then` return

7
src/Language.hs
View File

@ -10,9 +10,8 @@ import qualified Syntax as S
import Term
-- | A programming language.
data Language =
C
| Go
data Language
= Go
| JavaScript
| JSON
| Markdown
@ -24,8 +23,6 @@ data Language =
-- | Returns a Language based on the file extension (including the ".").
languageForType :: String -> Maybe Language
languageForType mediaType = case mediaType of
".h" -> Just C
".c" -> Just C
".json" -> Just JSON
".md" -> Just Markdown
".rb" -> Just Ruby

19
src/Language/C.hs
View File

@ -1,19 +0,0 @@
{-# LANGUAGE DataKinds #-}
module Language.C where
import Data.Source
import Info
import Prologue
import qualified Syntax as S
import Term
termAssignment
:: Source -- ^ The source of the term.
-> Category -- ^ The category for the term.
-> [ SyntaxTerm DefaultFields ] -- ^ The child nodes of the term.
-> Maybe (S.Syntax (SyntaxTerm DefaultFields)) -- ^ The resulting term, in Maybe.
termAssignment _ _ _ = Nothing
categoryForCProductionName :: Text -> Category
categoryForCProductionName = Other

2
src/Parser.hs
View File

@ -30,7 +30,6 @@ import Syntax hiding (Go)
import Term
import qualified Text.Parser.TreeSitter as TS
import Text.Parser.TreeSitter.Language (Symbol)
import Text.Parser.TreeSitter.C
import Text.Parser.TreeSitter.Go
import Text.Parser.TreeSitter.Python
import Text.Parser.TreeSitter.Ruby
@ -58,7 +57,6 @@ data Parser term where
parserForLanguage :: Maybe Language -> Parser (SyntaxTerm DefaultFields)
parserForLanguage Nothing = LineByLineParser
parserForLanguage (Just language) = case language of
C -> TreeSitterParser tree_sitter_c
Go -> TreeSitterParser tree_sitter_go
JSON -> TreeSitterParser tree_sitter_json
JavaScript -> TreeSitterParser tree_sitter_typescript

7
src/TreeSitter.hs
View File

@ -16,7 +16,6 @@ import Data.Source
import Data.Span
import qualified Data.Syntax.Assignment as A
import Language
import qualified Language.C as C
import qualified Language.Go as Go
import qualified Language.TypeScript as TS
import qualified Language.Ruby as Ruby
@ -27,7 +26,6 @@ import qualified Syntax as S
import Term
import Text.Parser.TreeSitter hiding (Language(..))
import qualified Text.Parser.TreeSitter as TS
import qualified Text.Parser.TreeSitter.C as TS
import qualified Text.Parser.TreeSitter.Go as TS
import qualified Text.Parser.TreeSitter.Ruby as TS
import qualified Text.Parser.TreeSitter.TypeScript as TS
@ -112,7 +110,6 @@ assignTerm language source annotation children allChildren =
_ -> defaultTermAssignment source (category annotation) children allChildren
where assignTermByLanguage :: Source -> Category -> [ SyntaxTerm DefaultFields ] -> Maybe (S.Syntax (SyntaxTerm DefaultFields))
assignTermByLanguage = case languageForTSLanguage language of
Just C -> C.termAssignment
Just Language.Go -> Go.termAssignment
Just Ruby -> Ruby.termAssignment
Just TypeScript -> TS.termAssignment
@ -166,7 +163,6 @@ categoryForLanguageProductionName = withDefaults . byLanguage
s -> productionMap s
byLanguage language = case languageForTSLanguage language of
Just C -> C.categoryForCProductionName
Just Ruby -> Ruby.categoryForRubyName
Just Language.Go -> Go.categoryForGoName
Just TypeScript -> TS.categoryForTypeScriptName
@ -175,8 +171,7 @@ categoryForLanguageProductionName = withDefaults . byLanguage
languageForTSLanguage :: Ptr TS.Language -> Maybe Language
languageForTSLanguage = flip lookup
[ (TS.tree_sitter_c, C)
, (TS.tree_sitter_go, Language.Go)
[ (TS.tree_sitter_go, Language.Go)
, (TS.tree_sitter_ruby, Ruby)
, (TS.tree_sitter_typescript, TypeScript)
]

75
test/Data/Syntax/Assignment/Spec.hs
View File

@ -36,6 +36,81 @@ spec = do
`shouldBe`
Right [Out "hello"]
it "distributes through overlapping committed choices, matching the left alternative" $
fst <$> runAssignment headF "(red (green))" (symbol Red *> children green <|> symbol Red *> children blue) (makeState [node Red 0 13 [node Green 5 12 []]])
`shouldBe`
Right (Out "(green)")
it "distributes through overlapping committed choices, matching the right alternative" $
fst <$> runAssignment headF "(red (blue))" (symbol Red *> children green <|> symbol Red *> children blue) (makeState [node Red 0 12 [node Blue 5 11 []]])
`shouldBe`
Right (Out "(blue)")
it "distributes through overlapping committed choices, matching the left alternatives" $
fst <$> runAssignment headF "magenta green green" (symbol Magenta *> many green <|> symbol Magenta *> many blue) (makeState [node Magenta 0 7 [], node Green 8 13 [], node Green 14 19 []])
`shouldBe`
Right [Out "green", Out "green"]
it "distributes through overlapping committed choices, matching the right alternatives" $
fst <$> runAssignment headF "magenta blue blue" (symbol Magenta *> many green <|> symbol Magenta *> many blue) (makeState [node Magenta 0 7 [], node Blue 8 12 [], node Blue 13 17 []])
`shouldBe`
Right [Out "blue", Out "blue"]
it "distributes through overlapping committed choices, matching the empty list" $
fst <$> runAssignment headF "magenta" (symbol Magenta *> (Left <$> many green) <|> symbol Magenta *> (Right <$> many blue)) (makeState [node Magenta 0 7 []])
`shouldBe`
Right (Left [])
it "distributes through overlapping committed choices, dropping anonymous nodes & matching the left alternative" $
fst <$> runAssignment headF "magenta green" (symbol Magenta *> green <|> symbol Magenta *> blue) (makeState [node Magenta 0 7 [], node Green 8 13 []])
`shouldBe`
Right (Out "green")
it "distributes through overlapping committed choices, dropping anonymous nodes & matching the right alternative" $
fst <$> runAssignment headF "magenta blue" (symbol Magenta *> green <|> symbol Magenta *> blue) (makeState [node Magenta 0 7 [], node Blue 8 12 []])
`shouldBe`
Right (Out "blue")
it "alternates repetitions, matching the left alternative" $
fst <$> runAssignment headF "green green" (many green <|> many blue) (makeState [node Green 0 5 [], node Green 6 11 []])
`shouldBe`
Right [Out "green", Out "green"]
it "alternates repetitions, matching the right alternative" $
fst <$> runAssignment headF "blue blue" (many green <|> many blue) (makeState [node Blue 0 4 [], node Blue 5 9 []])
`shouldBe`
Right [Out "blue", Out "blue"]
it "alternates repetitions, matching at the end of input" $
fst <$> runAssignment headF "" (many green <|> many blue) (makeState [])
`shouldBe`
Right []
it "distributes through children rules" $
fst <$> runAssignment headF "(red (blue))" (children (many green) <|> children (many blue)) (makeState [node Red 0 12 [node Blue 5 11 []]])
`shouldBe`
Right [Out "(blue)"]
it "matches rules to the left of pure" $
fst <$> runAssignment headF "green" ((green <|> pure (Out "other") <|> blue) <* many source) (makeState [node Green 0 5 []])
`shouldBe`
Right (Out "green")
it "matches rules to the right of pure" $
fst <$> runAssignment headF "blue" ((green <|> pure (Out "other") <|> blue) <* many source) (makeState [node Blue 0 4 []])
`shouldBe`
Right (Out "blue")
it "matches other nodes with pure" $
fst <$> runAssignment headF "red" ((green <|> pure (Out "other") <|> blue) <* many source) (makeState [node Red 0 3 []])
`shouldBe`
Right (Out "other")
it "matches at end with pure" $
fst <$> runAssignment headF "red" ((green <|> pure (Out "other") <|> blue) <* many source) (makeState [])
`shouldBe`
Right (Out "other")
describe "symbol" $ do
it "matches nodes with the same symbol" $
fst <$> runAssignment headF "hello" red (makeState [node Red 0 5 []]) `shouldBe` Right (Out "hello")