[new-hs-indexer #4] New Haskell Indexer

.github/workflows/ci.yml

@@ -171,9 +171,9 @@ jobs:
       - name: Build glean-clang
         run: make glean-clang
 
-      - if: matrix.ghc != '8.6.5' && matrix.ghc != '9.4.7'
-        name: Build hiedb-indexer
-        run: make glean-hiedb
+      - if: matrix.ghc != '8.6.5' && matrix.ghc != '8.8.4' && matrix.ghc != '8.10.7'
+        name: Build hie-indexer
+        run: make glean-hie
 
       - name: Run tests
         run: make test

Makefile

@@ -310,9 +310,9 @@ glass::
 glean-clang:: gen-schema glean glean.cabal cxx-libraries
 	$(CABAL) build glean-clang
 
-.PHONY: glean-hiedb
-glean-hiedb:: glean.cabal cxx-libraries
-	$(CABAL) build hiedb-indexer
+.PHONY: glean-hie
+glean-hie:: glean.cabal cxx-libraries
+	$(CABAL) build hie-indexer
 
 define bash_macros
 call_cabal() {

glean.cabal.in

@@ -65,6 +65,12 @@ common fb-cpp
 common exe
   ghc-options: -threaded -rtsopts
 
+common haskell-indexer
+  if impl(ghc >= 9.2)
+    buildable: True
+  else
+    buildable: False
+
 flag clang
      default: False
 
@@ -1098,40 +1104,26 @@ executable hack-derive
         glean:stubs,
         glean:util,
 
--- Haskell indexer via hiedb
-executable hiedb-indexer
-    import: deps, fb-haskell, exe
-    if impl(ghc >= 8.8 && < 9.4)
-      buildable: True
-    else
-      buildable: False
+-- Haskell indexer via hie
+executable hie-indexer
+    import: deps, fb-haskell, exe, haskell-indexer
     hs-source-dirs: glean/lang/haskell
-    main-is: HieDBIndexer/Main.hs
+    main-is: HieIndexer/Main.hs
     other-modules:
-        HieDBIndexer.Builder
-        HieDBIndexer.DefaultMain
-        HieDBIndexer.Glean
-        HieDBIndexer.HieDB
-        HieDBIndexer.Options
-        HieDBIndexer.Trace
-        HieDBIndexer.Types
-    ghc-options: -main-is HieDBIndexer.Main
+        HieIndexer.Index
+        HieIndexer.Options
+    ghc-options: -main-is HieIndexer.Main
     build-depends:
         ghc,
         glean:client-hs,
         glean:client-hs-local,
         glean:core,
-        glean:db,
-        glean:if-glean-hs,
         glean:lib,
-        glean:lib-derive,
         glean:schema,
         glean:stubs,
         glean:util,
         hie-compat < 0.3.1.2,
-        hiedb < 0.4.3,
-        split,
-        sqlite-simple,
+        hiedb < 0.4.3
 
 -- -----------------------------------------------------------------------------
 -- LSIF support
@@ -1795,6 +1787,17 @@ test-suite angle-test-misc
     main-is: Angle/MiscTest.hs
     ghc-options: -main-is Angle.MiscTest
 
+test-suite api
+    import: test
+    type: exitcode-stdio-1.0
+    main-is: ApiTest.hs
+    ghc-options: -main-is ApiTest
+    build-depends:
+        glean:stubs,
+        glean:core,
+        glean:if-glean-hs,
+        glean:schema
+
 test-suite cppexception
     import: test
     type: exitcode-stdio-1.0
@@ -2141,8 +2144,34 @@ test-suite glean-snapshot-hack
     if !flag(hack-tests)
         buildable: False
 
+test-suite glean-snapshot-haskell
+    import: fb-haskell, fb-cpp, deps, exe, haskell-indexer
+    hs-source-dirs: glean/lang/haskell/tests
+    type: exitcode-stdio-1.0
+    main-is: Main.hs
+    ghc-options: -main-is Main
+    build-depends:
+       glean:regression-test-lib,
+       glean:indexers
+    build-tool-depends:
+       glean:hie-indexer,
+       glean:glean
+
+test-suite glean-snapshot-codemarkup-haskell
+    import: fb-haskell, fb-cpp, deps, exe, haskell-indexer
+    hs-source-dirs: glean/lang/codemarkup/tests/haskell
+    type: exitcode-stdio-1.0
+    main-is: Main.hs
+    ghc-options: -main-is Main
+    build-depends:
+       glean:regression-test-lib,
+       glean:indexers
+    build-tool-depends:
+       glean:hie-indexer,
+       glean:glean
+
 test-suite glean-snapshot-rust-lsif
-    import: fb-haskell, deps
+    import: fb-haskell, deps, exe
     hs-source-dirs: glean/lang/rust-lsif/tests
     type: exitcode-stdio-1.0
     main-is: Glean/Regression/RustLsif/Main.hs
@@ -2330,6 +2359,19 @@ test-suite glass-regression-hack
     if !flag(hack-tests)
         buildable: False
 
+test-suite glass-regression-haskell
+    import: glass-regression-deps, fb-haskell, deps, exe, haskell-indexer
+    type: exitcode-stdio-1.0
+    main-is: Glean/Glass/Regression/Haskell/Main.hs
+    ghc-options: -main-is Glean.Glass.Regression.Haskell.Main
+    other-modules: Glean.Glass.Regression.Haskell
+    build-depends:
+        glean:client-hs,
+        glean:indexers,
+        glean:util
+    build-tool-depends:
+        glean:hie-indexer
+
 test-suite glass-regression-typescript
     import: glass-regression-deps, fb-haskell, deps, exe
     type: exitcode-stdio-1.0

glean/glass/Glean/Glass/RepoMapping.hs

@@ -45,6 +45,7 @@ gleanIndices_ = Map.fromList
   , (RepoName "test",
       [("test", Language_JavaScript)
       ,("test", Language_Hack)
+      ,("test", Language_Haskell)
       ,("test", Language_Cpp)
       ,("test", Language_PreProcessor)
       ,("test", Language_Python)

glean/glass/Glean/Glass/Search/Haskell.hs

@@ -15,32 +15,74 @@ module Glean.Glass.Search.Haskell
 
 import Data.Text ( Text )
 import qualified Data.Text as Text ( intercalate )
+import Util.Text
 
 import Glean.Angle as Angle
 
 import Glean.Glass.Search.Class
-import Glean.Glass.Query ( entityLocation )
 
 import qualified Glean.Schema.CodeHs.Types as Haskell
 import qualified Glean.Schema.CodemarkupTypes.Types as Code
-import qualified Glean.Schema.SearchHs.Types as Haskell
-import qualified Glean.Schema.Src.Types as Src
+import qualified Glean.Schema.Hs.Types as Hs
 
 instance Search (ResultLocation Haskell.Entity) where
   symbolSearch [] = return $ None "Haskell.symbolSearch: empty"
-  symbolSearch toks = do
-    searchSymbolId toks $ searchByName $ Text.intercalate "." toks
-
--- code.hs:searchByName
-searchByName :: Text -> Angle (ResultLocation Haskell.Entity)
-searchByName sym =
-  vars $ \(ent :: Angle Haskell.Entity) (file :: Angle Src.File)
-    (rangespan :: Angle Code.RangeSpan) (lname :: Angle Text) ->
-  tuple (ent, file, rangespan, lname) `where_` [
-    wild .= predicate @Haskell.SearchByName (
-      rec $
-        field @"name" (string sym) $
-        field @"entity" ent
-      end),
-    entityLocation (alt @"hs" ent) file rangespan lname
-  ]
+  symbolSearch toks@(pkg : rest) = do
+    case reverse rest of
+      end : start : ident : namespace : mod
+        | Right e <- textToInt end,
+          Right s <- textToInt start,
+          Just ns <- fromNamespace namespace ->
+          searchSymbolId toks $
+            symbolIdQuery pkg (Text.intercalate "." (reverse mod)) ident ns
+              (Just (s,e))
+      ident : namespace : mod
+        | Just ns <- fromNamespace namespace ->
+          searchSymbolId toks $
+            symbolIdQuery pkg (Text.intercalate "." (reverse mod)) ident ns
+              Nothing
+      _ -> return $ None "Haskell.symbolSearch: empty"
+    where
+    fromNamespace "var" = Just Hs.Namespace_var_
+    fromNamespace "ty" = Just Hs.Namespace_tycon
+    fromNamespace "con" = Just Hs.Namespace_datacon
+    fromNamespace "tyvar" = Just Hs.Namespace_tyvar
+    fromNamespace _ = Nothing
+
+
+symbolIdQuery
+  :: Text  -- ^ package (ignored (TODO))
+  -> Text  -- ^ module name
+  -> Text  -- ^ identifier
+  -> Hs.Namespace -- ^ namespace (var, datacon, tycon, tyvar)
+  -> Maybe (Int, Int)  -- ^ span, for local names
+  -> Angle (ResultLocation Haskell.Entity)
+symbolIdQuery _pkg mod ident ns sort =
+  vars $ \name file span ->
+    tuple (
+      alt @"name" (asPredicate name),
+      file,
+      alt @"span" span,
+      string ident
+    ) `where_` [
+        name .= predicate @Hs.Name (
+          rec $
+            field @"occ" (rec $
+              field @"name" (string ident) $
+              field @"namespace_" (enum ns) end) $
+            field @"mod" (rec $
+              field @"name" (string mod) end) $
+            field @"sort" (
+              case sort of
+                Nothing -> alt @"external" wild
+                Just (s,l) -> alt @"internal" (rec $
+                  field @"start" (nat (fromIntegral s)) $
+                  field @"length" (nat (fromIntegral l)) end)
+            ) end),
+        stmt $ predicate @Hs.DeclarationLocation (
+          rec $
+            field @"name" (asPredicate name) $
+            field @"file" (asPredicate file) $
+            field @"span" span end
+        )
+    ]

glean/glass/Glean/Glass/SymbolId/Hs.hs

@@ -10,70 +10,74 @@
 
 module Glean.Glass.SymbolId.Hs ({- instances -}) where
 
-import Data.Text (Text)
+import Data.Char
 import qualified Data.Text as Text
+import TextShow
 
 import Glean.Glass.SymbolId.Class
 import Glean.Glass.Types (Name(..))
-import Glean.Schema.CodeHs.Types as Hs (Entity (..))
+import Glean.Schema.CodeHs.Types as Hs (Entity(..))
 import qualified Glean
 import qualified Glean.Schema.Hs.Types as Hs
 import qualified Glean.Schema.Src.Types as Src
 
+-- REPO/hs/containers/Data/Map/{var|datacon|tyvar|tycon}/toList[/START/END]
+
 instance Symbol Hs.Entity where
-  toSymbol (Hs.Entity_definition d) = toSymbolPredicate d
-  toSymbol (Hs.Entity_function_ d) = toSymbolPredicate d
-  toSymbol (Hs.Entity_class_ d) = toSymbolPredicate d
-  toSymbol Hs.Entity_EMPTY = return []
+  toSymbol (Hs.Entity_name x) = toSymbolPredicate x
+  toSymbol (Hs.Entity_mod x) = toSymbolPredicate x
+  toSymbol _ = error "toSymbol: unknown Hs.Entity"
 
-instance Symbol Hs.Definition_key where
-  toSymbol (Hs.Definition_key name _) = do
-    n <- Glean.keyOf name
-    return (Text.splitOn "." n)
+instance Symbol Hs.Name_key where
+  toSymbol (Hs.Name_key occ mod sort) = do
+    m <- toSymbol mod
+    o <- toSymbol occ
+    s <- toSymbol sort
+    return $ m <> o <> s
 
-instance Symbol Hs.FunctionDefinition_key where
-  toSymbol (Hs.FunctionDefinition_key fnName Src.Range{..}) = do
-    name <- Glean.keyOf fnName
-    fname <- Glean.keyOf range_file
-    return (fname : Text.splitOn "." name)
+instance Symbol Hs.Module where
+  toSymbol = toSymbolPredicate
 
-instance Symbol Hs.Class_key where
-  toSymbol (Hs.Class_key clsName Src.Range{..}) = do
-    name <- Glean.keyOf clsName
-    fname <- Glean.keyOf range_file
-    return (fname : Text.splitOn "." name)
+instance Symbol Hs.OccName where
+  toSymbol = toSymbolPredicate
 
-instance ToQName Hs.Entity where
-  toQName (Hs.Entity_definition d) = Glean.keyOf d >>= toQName
-  toQName (Hs.Entity_function_ d) = Glean.keyOf d >>= toQName
-  toQName (Hs.Entity_class_ d) = Glean.keyOf d >>= toQName
-  toQName Hs.Entity_EMPTY =
-    return $ Left "toQName: Haskell: empty qname"
-
-instance ToQName Hs.Definition_key where
-  toQName (Hs.Definition_key name _) = do
+instance Symbol Hs.Module_key where
+  toSymbol (Hs.Module_key name unit) = do
+    u <- Glean.keyOf unit
     n <- Glean.keyOf name
-    return $ case reverse (Text.splitOn "." n) of
-      [] -> Left "toQName: Haskell: empty function qname"
-      [x] -> Right (Name x, Name "")
-      (x:xs) -> Right (Name x, joinDotted xs)
+    -- unit names are things like glean-0.1.0.0-inplace-core
+    -- let's strip the version and everything after it
+    let pkg = Text.intercalate "-" (fst (break isVer (Text.splitOn "-" u)))
+    return (pkg : Text.splitOn "." n)
+    where
+    isVer t
+      | Just (d, _) <- Text.uncons t = isDigit d
+      | otherwise = False
 
-instance ToQName Hs.FunctionDefinition_key where
-  toQName (Hs.FunctionDefinition_key fnName _) = do
-    name <- Glean.keyOf fnName
-    return $ case reverse (Text.splitOn "." name) of
-      [] -> Left "toQName: Haskell: empty function qname"
-      [x] -> Right (Name x, Name "")
-      (x:xs) -> Right (Name x, joinDotted xs)
+instance Symbol Hs.OccName_key where
+  toSymbol (Hs.OccName_key name namespace) = do
+    let sp = case namespace of
+          Hs.Namespace_var_ -> "var"
+          Hs.Namespace_datacon -> "con"
+          Hs.Namespace_tyvar -> "tyvar"
+          Hs.Namespace_tycon -> "ty"
+          _ -> error "namespace"
+    return [sp,name]
 
+instance Symbol Hs.NameSort where
+  toSymbol Hs.NameSort_external{} = return []
+  toSymbol (Hs.NameSort_internal (Src.ByteSpan start end)) =
+    return [showt (Glean.fromNat start), showt (Glean.fromNat end)]
+  toSymbol _ = error "toSymbol: unknown Hs.NameSort"
 
-instance ToQName Hs.Class_key where
-  toQName (Hs.Class_key clsName _) = do
-    name <- Glean.keyOf clsName
-    return $ case reverse (Text.splitOn "." name) of
-      [] -> Left "toQName: Haskell: empty class qname"
-      [x] -> Right (Name x, Name "")
-      (x:xs) -> Right (Name x, joinDotted xs)
+instance ToQName Hs.Entity where
+  toQName (Hs.Entity_name n) = Glean.keyOf n >>= toQName
+  toQName (Hs.Entity_mod _) = error "TODO: ToQName Hs.Entity_mod"
+  toQName _ = error "ToQName: unknown Hs.Entity"
 
-joinDotted :: [Text] -> Name
-joinDotted = Name . Text.intercalate "." . reverse
+instance ToQName Hs.Name_key where
+  toQName (Hs.Name_key occ mod _sort) = do
+    Hs.Module_key m _ <- Glean.keyOf mod
+    modname <- Glean.keyOf m
+    Hs.OccName_key n _ <- Glean.keyOf occ
+    return $ Right (Name modname, Name n)