Merge branch 'master' into path-ological

.github/workflows/haskell.yml

@@ -37,7 +37,7 @@ jobs:
       name: Cache ~/.cabal/store
       with:
         path: ~/.cabal/store
-        key: ${{ runner.os }}-${{ matrix.ghc }}-v3-cabal-store
+        key: ${{ runner.os }}-${{ matrix.ghc }}-v4-cabal-store
 
     - uses: actions/cache@v1
       name: Cache dist-newstyle

semantic-source/src/Source/Loc.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveGeneric, DerivingVia, RankNTypes #-}
+{-# LANGUAGE DeriveGeneric, DerivingVia, RankNTypes, NamedFieldPuns, OverloadedStrings #-}
 module Source.Loc
 ( Loc(..)
 , byteRange_
@@ -7,6 +7,7 @@ module Source.Loc
 ) where
 
 import Control.DeepSeq (NFData)
+import Data.Aeson (ToJSON(..), object, (.=))
 import Data.Hashable (Hashable)
 import Data.Monoid.Generic
 import GHC.Generics (Generic)
@@ -28,6 +29,9 @@ instance HasSpan Loc where
   span_ = lens span (\l s -> l { span = s })
   {-# INLINE span_ #-}
 
+instance ToJSON Loc where
+  toJSON Loc{byteRange, span} = object ["sourceRange" .= byteRange
+                                      , "sourceSpan" .= span]
 
 byteRange_ :: Lens' Loc Range
 byteRange_ = lens byteRange (\l r -> l { byteRange = r })
@@ -38,3 +42,4 @@ type Lens' s a = forall f . Functor f => (a -> f a) -> (s -> f s)
 lens :: (s -> a) -> (s -> a -> s) -> Lens' s a
 lens get put afa s = fmap (put s) (afa (get s))
 {-# INLINE lens #-}
+

semantic-source/src/Source/Range.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveAnyClass, DeriveGeneric, RankNTypes #-}
+{-# LANGUAGE DeriveAnyClass, DeriveGeneric, RankNTypes, NamedFieldPuns #-}
 module Source.Range
 ( Range(..)
 , point
@@ -10,7 +10,7 @@ module Source.Range
 ) where
 
 import Control.DeepSeq (NFData)
-import Data.Aeson (ToJSON)
+import Data.Aeson (ToJSON(..))
 import Data.Hashable (Hashable)
 import Data.Semilattice.Lower (Lower(..))
 import GHC.Generics (Generic)
@@ -20,11 +20,13 @@ data Range = Range
   { start :: {-# UNPACK #-} !Int
   , end   :: {-# UNPACK #-} !Int
   }
-  deriving (Eq, Generic, Ord, Show, ToJSON)
+  deriving (Eq, Generic, Ord, Show)
 
 instance Hashable Range
 instance NFData   Range
 
+
+
 -- $
 -- prop> a <> (b <> c) === (a <> b) <> (c :: Range)
 instance Semigroup Range where
@@ -33,6 +35,8 @@ instance Semigroup Range where
 instance Lower Range where
   lowerBound = Range 0 0
 
+instance ToJSON Range where
+  toJSON Range { start, end } = toJSON [ start, end ]
 
 -- | Construct a 'Range' with a given value for both its start and end indices.
 point :: Int -> Range
@@ -61,3 +65,4 @@ lens get put afa s = fmap (put s) (afa (get s))
 -- $setup
 -- >>> import Test.QuickCheck
 -- >>> instance Arbitrary Range where arbitrary = Range <$> arbitrary <*> arbitrary ; shrink (Range s e) = Range <$> shrink s <*> shrink e
+

semantic-tsx/src/Language/TSX/Tags.hs

@@ -100,6 +100,19 @@ instance ToTags Tsx.Class where
     } = yieldTag text Class loc byteRange >> gtags t
   tags t = gtags t
 
+instance ToTags Tsx.Module where
+  tags t@Tsx.Module
+    { ann = loc@Loc { byteRange }
+    , name
+    } = match name
+    where
+      match expr = case expr of
+        Prj Tsx.Identifier { text } -> yield text
+        -- TODO: Handle NestedIdentifiers and Strings
+        -- Prj Tsx.NestedIdentifier { extraChildren } -> match
+        _ -> gtags t
+      yield text = yieldTag text Module loc byteRange >> gtags t
+
 instance (ToTags l, ToTags r) => ToTags (l :+: r) where
   tags (L1 l) = tags l
   tags (R1 r) = tags r
@@ -222,7 +235,7 @@ instance ToTags Tsx.MemberExpression
 instance ToTags Tsx.MetaProperty
 -- instance ToTags Tsx.MethodDefinition
 instance ToTags Tsx.MethodSignature
-instance ToTags Tsx.Module
+-- instance ToTags Tsx.Module
 instance ToTags Tsx.NamedImports
 instance ToTags Tsx.NamespaceImport
 instance ToTags Tsx.NestedIdentifier

semantic-typescript/src/Language/TypeScript/Tags.hs

@@ -93,6 +93,19 @@ instance ToTags Ts.CallExpression where
         _ -> gtags t
       yield name = yieldTag name Call loc byteRange >> gtags t
 
+instance ToTags Ts.Module where
+  tags t@Ts.Module
+    { ann = loc@Loc { byteRange }
+    , name
+    } = match name
+    where
+      match expr = case expr of
+        Prj Ts.Identifier { text } -> yield text
+        -- TODO: Handle NestedIdentifiers and Strings
+        -- Prj Tsx.NestedIdentifier { extraChildren } -> match
+        _ -> gtags t
+      yield text = yieldTag text Module loc byteRange >> gtags t
+
 instance (ToTags l, ToTags r) => ToTags (l :+: r) where
   tags (L1 l) = tags l
   tags (R1 r) = tags r
@@ -215,7 +228,7 @@ instance ToTags Ts.MemberExpression
 instance ToTags Ts.MetaProperty
 -- instance ToTags Ts.MethodDefinition
 instance ToTags Ts.MethodSignature
-instance ToTags Ts.Module
+-- instance ToTags Ts.Module
 instance ToTags Ts.NamedImports
 instance ToTags Ts.NamespaceImport
 instance ToTags Ts.NestedIdentifier

src/Parsing/TreeSitter.hs

@@ -12,7 +12,6 @@ import Prologue
 import           Control.Carrier.Reader
 import qualified Control.Exception as Exc
 import           Foreign
-import           Foreign.C.Types (CBool (..))
 
 import           Data.AST (AST, Node (Node))
 import           Data.Blob
@@ -85,7 +84,6 @@ runParse parseTimeout language Blob{..} action =
   liftIO . Exc.tryJust fromException . TS.withParser language $ \ parser -> do
     let timeoutMicros = fromIntegral $ toMicroseconds parseTimeout
     TS.ts_parser_set_timeout_micros parser timeoutMicros
-    TS.ts_parser_halt_on_error parser (CBool 1)
     compatible <- TS.ts_parser_set_language parser language
     if compatible then
       TS.withParseTree parser (Source.bytes blobSource) $ \ treePtr -> do

test/Rendering/TOC/Spec.hs

@@ -141,7 +141,7 @@ spec = do
     it "produces JSON output if there are parse errors" $ do
       blobs <- blobsForPaths (Path.relFile "ruby/toc/methods.A.rb") (Path.relFile "ruby/toc/methods.X.rb")
       output <- runTaskOrDie (runReader defaultLanguageModes (diffSummaryBuilder Format.JSON [blobs]))
-      runBuilder output `shouldBe` ("{\"files\":[{\"path\":\"test/fixtures/ruby/toc/methods.A.rb -> test/fixtures/ruby/toc/methods.X.rb\",\"language\":\"Ruby\",\"changes\":[{\"category\":\"Method\",\"term\":\"bar\",\"span\":{\"start\":{\"line\":1,\"column\":1},\"end\":{\"line\":2,\"column\":4}},\"changeType\":\"REMOVED\"},{\"category\":\"Method\",\"term\":\"baz\",\"span\":{\"start\":{\"line\":4,\"column\":1},\"end\":{\"line\":5,\"column\":4}},\"changeType\":\"REMOVED\"}],\"errors\":[{\"error\":\"expected end of input nodes, but got ParseError\",\"span\":{\"start\":{\"line\":1,\"column\":1},\"end\":{\"line\":2,\"column\":3}}}]}]}\n" :: ByteString)
+      runBuilder output `shouldBe` ("{\"files\":[{\"path\":\"test/fixtures/ruby/toc/methods.A.rb -> test/fixtures/ruby/toc/methods.X.rb\",\"language\":\"Ruby\",\"changes\":[{\"category\":\"Method\",\"term\":\"bar\",\"span\":{\"start\":{\"line\":1,\"column\":1},\"end\":{\"line\":2,\"column\":4}},\"changeType\":\"REMOVED\"},{\"category\":\"Method\",\"term\":\"baz\",\"span\":{\"start\":{\"line\":4,\"column\":1},\"end\":{\"line\":5,\"column\":4}},\"changeType\":\"REMOVED\"}],\"errors\":[{\"error\":\"expected end of input nodes, but got ParseError\",\"span\":{\"start\":{\"line\":1,\"column\":1},\"end\":{\"line\":3,\"column\":1}}}]}]}\n" :: ByteString)
 
     it "ignores anonymous functions" $ do
       blobs <- blobsForPaths (Path.relFile "ruby/toc/lambda.A.rb") (Path.relFile "ruby/toc/lambda.B.rb")