Stub in a semantic-java package.

cabal.project

@@ -1,5 +1,6 @@
 packages: .
           semantic-core
+          semantic-java
           semantic-python
           semantic-source
           semantic-tags

semantic-java/LICENSE

@@ -0,0 +1,21 @@
+MIT License
+
+Copyright (c) 2019 GitHub
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.

semantic-java/README.md

@@ -0,0 +1,18 @@
+# semantic-java
+
+Semantic support for Java.
+
+
+## Development
+
+This project consists of a Haskell package named `semantic-java`. The library’s sources are in [`src`][].
+
+Development of `semantic-java` is typically done using `cabal v2-build`:
+
+```shell
+cabal v2-build # build the library
+cabal v2-repl  # load the package into ghci
+cabal v2-test  # build and run the doctests
+```
+
+[`src`]: https://github.com/github/semantic/tree/master/semantic-java/src

semantic-java/Setup.hs

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

semantic-java/semantic-java.cabal

@@ -0,0 +1,56 @@
+cabal-version:       2.4
+
+name:                semantic-java
+version:             0.0.0.0
+synopsis:            Semantic support for Java
+description:         Semantic support for Java.
+homepage:            https://github.com/github/semantic/tree/master/semantic-java#readme
+bug-reports:         https://github.com/github/semantic/issues
+license:             MIT
+license-file:        LICENSE
+author:              The Semantic authors
+maintainer:          opensource+semantic@github.com
+copyright:           (c) 2019 GitHub, Inc.
+category:            Language
+build-type:          Simple
+stability:           alpha
+extra-source-files:  README.md
+
+tested-with:         GHC == 8.6.5
+
+library
+  exposed-modules:
+    Language.Java
+    Language.Java.Tags
+  build-depends:
+      base                >= 4.12 && < 5
+    , bytestring         ^>= 0.10.8.2
+    , fused-effects      ^>= 0.5
+    , semantic-source    ^>= 0.0
+    , semantic-tags      ^>= 0.0
+    , text               ^>= 1.2.3.1
+    , tree-sitter        ^>= 0.4
+    , tree-sitter-java   ^>= 0.3
+  hs-source-dirs:      src
+  default-language:    Haskell2010
+  ghc-options:
+    -Weverything
+    -Wno-missing-local-signatures
+    -Wno-missing-import-lists
+    -Wno-implicit-prelude
+    -Wno-safe
+    -Wno-unsafe
+    -Wno-name-shadowing
+    -Wno-monomorphism-restriction
+    -Wno-missed-specialisations
+    -Wno-all-missed-specialisations
+    -Wno-star-is-type
+
+test-suite doctest
+  type:                exitcode-stdio-1.0
+  main-is:             Doctest.hs
+  build-depends:       base
+                     , doctest >=0.7 && <1.0
+                     , semantic-java
+  hs-source-dirs:      test
+  default-language:    Haskell2010

semantic-java/src/Language/Java.hs

@@ -0,0 +1,17 @@
+-- | Semantic functionality for Java programs.
+module Language.Java
+( Term(..)
+) where
+
+import qualified Language.Java.Tags as JavaTags
+import qualified Tags.Tagging.Precise as Tags
+import qualified TreeSitter.Java.AST as Java
+import qualified TreeSitter.Unmarshal as TS
+
+newtype Term a = Term { getTerm :: Java.Module a }
+
+instance TS.Unmarshal Term where
+  unmarshalNode node = Term <$> TS.unmarshalNode node
+
+instance Tags.ToTags Term where
+  tags src = Tags.runTagging src . JavaTags.tags . getTerm

semantic-java/src/Language/Java/Tags.hs

@@ -0,0 +1,60 @@
+{-# LANGUAGE AllowAmbiguousTypes, DataKinds, DisambiguateRecordFields, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, NamedFieldPuns, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-}
+module Language.Java.Tags
+( ToTags(..)
+) where
+
+import           Control.Effect.Reader
+import           Control.Effect.Writer
+import           Data.Foldable (traverse_)
+import           Data.Maybe (listToMaybe)
+import           Data.Monoid (Ap(..))
+import           Data.List.NonEmpty (NonEmpty(..))
+import           Data.Text as Text
+import           GHC.Generics
+import           Source.Loc
+import           Source.Range
+import           Source.Source as Source
+import           Tags.Tag
+import qualified Tags.Tagging.Precise as Tags
+import qualified TreeSitter.Java.AST as Java
+
+class ToTags t where
+  tags
+    :: ( Carrier sig m
+       , Member (Reader Source) sig
+       , Member (Writer Tags.Tags) sig
+       )
+    => t Loc
+    -> m ()
+
+instance (ToTagsBy strategy t, strategy ~ ToTagsInstance t) => ToTags t where
+  tags = tags' @strategy
+
+
+class ToTagsBy (strategy :: Strategy) t where
+  tags'
+    :: ( Carrier sig m
+       , Member (Reader Source) sig
+       , Member (Writer Tags.Tags) sig
+       )
+    => t Loc
+    -> m ()
+
+
+data Strategy = Generic | Custom
+
+type family ToTagsInstance t :: Strategy where
+  ToTagsInstance (_ :+: _)              = 'Custom
+  ToTagsInstance _                      = 'Generic
+
+
+instance (ToTags l, ToTags r) => ToTagsBy 'Custom (l :+: r) where
+  tags' (L1 l) = tags l
+  tags' (R1 r) = tags r
+
+firstLine :: Source -> Text
+firstLine = Text.takeWhile (/= '\n') . toText . Source.take 180
+
+
+instance (Generic1 t, Tags.GFoldable1 ToTags (Rep1 t)) => ToTagsBy 'Generic t where
+  tags' = getAp . Tags.gfoldMap1 @ToTags (Ap . tags) . from1

semantic-java/test/Doctest.hs

@@ -0,0 +1,12 @@
+module Main
+( main
+) where
+
+import System.Environment
+import Test.DocTest
+
+main :: IO ()
+main = do
+  args <- getArgs
+  autogen <- fmap (<> "/build/doctest/autogen") <$> lookupEnv "HASKELL_DIST_DIR"
+  doctest (maybe id ((:) . ("-i" <>)) autogen ("-isemantic-tags/src" : "--fast" : if null args then ["semantic-tags/src"] else args))

semantic.cabal

@@ -318,7 +318,7 @@ library
                      , tree-sitter-ruby ^>= 0.2
                      , tree-sitter-typescript ^>= 0.2.1
                      , tree-sitter-tsx ^>= 0.2.1
-                     , tree-sitter-java ^>= 0.2
+                     , tree-sitter-java ^>= 0.3
   if flag(release)
     cpp-options:       -DCOMPUTE_GIT_SHA