Use cabal-install-parsers and Cabal parser

app/Main.hs

@@ -26,12 +26,12 @@ main = do
             | any (("cabal.project" ==) . takeFileName) files -> "cabal"
             | any (("stack.yaml" ==) . takeFileName) files -> "stack"
             | otherwise -> "cabal"
-  cfs <- runMaybeT $ case name of
+  pkgs <- fmap (fromMaybe []) $ runMaybeT $ case name of
     "cabal" -> cabalPkgs pwd
-    _ -> stackYamlPkgs pwd
-  when (null cfs) $ error $
+    --_ -> stackYamlPkgs pwd
+  when (null pkgs) $ error $
     "No .cabal files found under"
       <> pwd
       <> "\n You may need to run stack build."
-  pkgs <- catMaybes <$> mapM (nestedPkg pwd) (concat cfs)
+  --pkgs <- catMaybes <$> mapM (nestedPkg pwd) (concat cfs)
   putStr <$> hieYaml name $ fmtPkgs name pkgs

implicit-hie.cabal

@@ -54,6 +54,8 @@ library
     , text >= 1.2
     , transformers >= 0.5
     , yaml >= 0.5
+    , cabal-install-parsers
+    , Cabal
   default-language: Haskell2010
 
 executable gen-hie

src/Hie/Locate.hs

@@ -1,38 +1,55 @@
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE TypeApplications  #-}
 
 module Hie.Locate
-  ( nestedPkg,
-    stackYamlPkgs,
+  ( stackYamlPkgs,
     cabalPkgs,
   )
 where
 
-import Control.Applicative
-import Control.Exception
-import Control.Monad
-import Control.Monad.IO.Class
-import Control.Monad.Trans.Maybe
-import Data.Attoparsec.Text (parseOnly)
-import Data.Either
-import Data.List
-import Data.Maybe
-import qualified Data.Text as T
-import qualified Data.Text.IO as T
-import Data.Yaml
-import GHC.Generics
-import Hie.Cabal.Parser
-import Hie.Yaml
-import System.Directory
-import System.FilePath.Posix
-import System.FilePattern.Directory (getDirectoryFiles)
+import           Cabal.Project
+import           Control.Applicative
+import           Control.Exception
+import           Control.Monad
+import           Control.Monad.IO.Class
+import           Control.Monad.Trans.Maybe
+import           Data.Attoparsec.Text                         (parseOnly)
+import           Data.Bifunctor
+import           Data.Either
+import           Data.List
+import           Data.Maybe
+import qualified Data.Text                                    as T
+import qualified Data.Text.IO                                 as T
+import           Data.Yaml
+import           Distribution.Pretty
+import           Distribution.Types.BuildInfo
+import           Distribution.Types.CondTree
+import           Distribution.Types.Executable
+import           Distribution.Types.GenericPackageDescription
+import           Distribution.Types.Library
+import           Distribution.Types.LibraryName
+import           Distribution.Types.PackageDescription
+import           Distribution.Types.PackageId
+import           Distribution.Types.PackageName
+import           Distribution.Types.TestSuite
+import           Distribution.Types.TestSuiteInterface
+import           GHC.Generics
+import           Hie.Cabal.Parser                             (CompType (..),
+                                                               Component (..),
+                                                               Package (..))
+import           Hie.Yaml
+import           System.Directory
+import           System.FilePath.Posix
+import           System.FilePattern.Directory                 (getDirectoryFiles)
 
 newtype Pkgs = Pkgs [FilePath]
   deriving (Eq, Ord)
 
 instance FromJSON Pkgs where
   parseJSON (Object v) = Pkgs <$> v .: "packages"
-  parseJSON _ = fail "could not read packages from stack.yaml"
+  parseJSON _          = fail "could not read packages from stack.yaml"
 
 stackYamlPkgs :: FilePath -> MaybeT IO [FilePath]
 stackYamlPkgs p = liftIO $
@@ -43,43 +60,43 @@ stackYamlPkgs p = liftIO $
           <$> getDirectoryFiles p (map (</> "*.cabal") f)
     Left e -> fail $ show e
 
-cabalPkgs :: FilePath -> MaybeT IO [FilePath]
+cabalPkgs :: FilePath -> MaybeT IO [Package]
 cabalPkgs p = do
   cp <- cabalP "cabal.project"
   cl <- cabalP "cabal.project.local"
-  case concat . rights $ map (parseOnly extractPkgs) $ rights [cp, cl] of
-    [] -> liftIO (cfs p) >>= \case
-      [] -> fail "no cabal files found"
-      h : _ -> pure [p </> h]
-    xs -> do
-      cd <- liftIO $ map (p </>) <$> getDirectoryFiles p (map (matchDirs . T.unpack) xs)
-      cf <-
-        liftIO $
-          mapM (\p -> if takeExtension p == ".cabal" then pure [p] else cfs p) cd
-      pure $ concat cf
+  case rights [cp, cl] of
+    -- FIXME parse cabal files w/o project file
+    --[] -> liftIO (cfs p) >>= \case
+      --[] -> fail "no cabal files found"
+      --h : _ -> pure [p </> h]
+    xs ->
+      fmap concat $ forM xs $ \Project{..} ->
+        forM prjPackages $ \(pkgPath, pkg) -> do
+          let pkgDir = takeDirectory pkgPath
+          let pkgDescr = packageDescription pkg
+          let name = T.pack $ unPackageName . pkgName . package $ pkgDescr
+          let lib = case condLibrary pkg of
+                Nothing -> []
+                Just lib -> Comp Lib (libNameToText $ libName $ condTreeData lib) . T.pack . (pkgDir </> ) <$> hsSourceDirs (libBuildInfo $ condTreeData lib)
+          let exes = concat $ exeToComponent pkgDir . condTreeData . snd <$> condExecutables pkg
+          let tests = concat $ uncurry (testSuiteToComponent pkgDir) . second condTreeData <$> condTestSuites pkg
+          return $ Package name $ lib <> exes <> tests
   where
-    cabalP n = liftIO (try $ T.readFile $ p </> n :: IO (Either IOException T.Text))
+    libNameToText LMainLibName          = ""
+    libNameToText (LSubLibName libName) = T.pack $ prettyShow libName
+
+    exeToComponent pkgDir exe = Comp Exe (T.pack $ prettyShow $ exeName exe) <$>
+      (T.pack . (</> modulePath exe) . (pkgDir </>) <$> hsSourceDirs (buildInfo exe)) -- TODO other-modules autogen-modules
+
+    testSuiteToComponent pkgDir name testSuite = Comp Test (T.pack $ prettyShow name) . T.pack . (pkgDir </>) <$>
+      hsSourceDirs (testBuildInfo testSuite)
+
+    testSuiteInterfaceToPath (TestSuiteExeV10 _ p) = p
+    testSuiteInterfaceToPath i = error $ "Unsupported test suite " <> show i
+
+    cabalP n = liftIO (try @IOException $ readProject $ p </> n)
     cfs d = filter ((".cabal" ==) . takeExtension) <$> listDirectory d
     matchDirs "." = "./*.cabal"
     matchDirs p | "/" `isSuffixOf` p || p == "." = p <> "*.cabal"
     matchDirs p | "*" `isSuffixOf` p || takeExtension p == "" = p <> "/*.cabal"
     matchDirs p = p
-
-nestedPkg :: FilePath -> FilePath -> IO (Maybe Package)
-nestedPkg parrent child = do
-  f' <- T.readFile child
-  case parsePackage' f' of
-    Right (Package n cs) -> do
-      let dir =
-            fromJust $ stripPrefix (splitDirectories parrent)
-              $ splitDirectories
-              $ fst (splitFileName child)
-          pkg =
-            Package n $
-              map
-                ( \(Comp t n p) ->
-                    Comp t n (T.pack $ joinPath dir </> T.unpack p)
-                )
-                cs
-      pure $ Just pkg
-    _ -> pure Nothing