Read cabal.project and stack.yaml packages

Author: Avi-D-coder

app/Main.hs

@@ -3,14 +3,15 @@
 module Main where
 
 import Control.Monad
+import Control.Monad.Trans.Maybe
 import Data.Attoparsec.Text
 import Data.List
 import Data.Maybe
 import qualified Data.Text as T
 import qualified Data.Text.IO as T
 import Hie.Cabal.Parser
-import Hie.Yaml
 import Hie.Locate
+import Hie.Yaml
 import System.Directory
 import System.Directory.Internal
 import System.FilePath.Posix
@@ -19,16 +20,17 @@ main :: IO ()
 main = do
   pwd <- getCurrentDirectory
   files <- listDirectory pwd
-  cfs <- nestedCabalFiles pwd
   let name =
         if  | any (("dist-newstyle" ==) . takeFileName) files -> "cabal"
             | any ((".stack-work" ==) . takeFileName) files -> "stack"
             | any (("stack.yaml" ==) . takeFileName) files -> "stack"
             | otherwise -> "cabal"
+  cfs <- runMaybeT $ case name of
+    "cabal" -> cabalPkgs pwd
+    _ -> stackYamlPkgs pwd
   when (null cfs) $ error $
     "No .cabal files found under"
       <> pwd
       <> "\n You may need to run stack build."
-  pkgs <- catMaybes <$> mapM (nestedPkg pwd) cfs
+  pkgs <- catMaybes <$> mapM (nestedPkg pwd) (concat cfs)
   putStr <$> hieYaml name $ fmtPkgs name pkgs
-

src/Hie/Cabal/Parser.hs

@@ -81,7 +81,9 @@ parseSecMain c s i = do
 parseQuoted :: Parser Text
 parseQuoted = do
   q <- char '"' <|> char '\''
-  takeTill (== q)
+  s <- takeTill (== q)
+  _ <- char q
+  pure s
 
 parseString :: Parser Name
 parseString = parseQuoted <|> unqualName

src/Hie/Locate.hs

@@ -3,17 +3,17 @@
 
 module Hie.Locate
   ( nestedPkg,
-    nestedCabalFiles,
     stackYamlPkgs,
-    cabalProjectPkgs,
+    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
+import Data.Attoparsec.Text (parseOnly)
 import Data.List
 import Data.Maybe
 import qualified Data.Text as T
@@ -25,6 +25,7 @@ import Hie.Yaml
 import System.Directory
 import System.Directory.Internal
 import System.FilePath.Posix
+import System.FilePattern.Directory (getDirectoryFiles)
 
 newtype Pkgs = Pkgs [FilePath]
   deriving (Eq, Ord)
@@ -39,27 +40,14 @@ stackYamlPkgs p = liftIO $
     Right (Pkgs f) -> pure f
     Left e -> fail $ show e
 
-cabalProjectPkgs :: FilePath -> MaybeT IO [FilePath]
-cabalProjectPkgs p = do
-  cp <- liftIO $ T.readFile $ p </> "cabal.project"
-  case parseOnly extractPkgs cp of
-    Right f -> pure $ map T.unpack f
-    _ -> fail "No packages found"
-
-nestedCabalFiles :: FilePath -> IO [FilePath]
-nestedCabalFiles f = do
-  fs <- listDirectory f
-  nf <-
-    fmap concat . mapM nestedCabalFiles
-      =<< filterM
-        (fmap (fileTypeIsDirectory . fileTypeFromMetadata) . getFileMetadata)
-        ( map (f </>) $
-            filter
-              (`notElem` [".git", "dist", "dist-newstyle", ".stack-work"])
-              fs
-        )
-  let cf = filter ((".cabal" ==) . takeExtension) fs
-  pure $ map (f </>) cf <> nf
+cabalPkgs :: FilePath -> MaybeT IO [FilePath]
+cabalPkgs p = do
+  cp <- liftIO (try $ T.readFile $ p </> "cabal.project" :: IO (Either IOException T.Text))
+  case parseOnly extractPkgs <$> cp of
+    Right (Right f) -> liftIO $ map (p </>) <$> getDirectoryFiles p (map T.unpack f)
+    _ -> filter ((".cabal" ==) . takeExtension) <$> liftIO (listDirectory p) >>= \case
+      [] -> fail "no cabal files found"
+      h : _ -> pure [p </> h]
 
 nestedPkg :: FilePath -> FilePath -> IO (Maybe Package)
 nestedPkg parrent child = do

test/Spec.hs

@@ -74,9 +74,13 @@ spec = do
     $ ("one\n two \n three3" :: Text) ~> parseList 1
       `shouldParse` ["one", "two", "three3"]
   describe "Should Succeed"
-    $ it "successfully parses newline list"
+    $ it "successfully parses newline comma list"
     $ ("one\n two,  three3" :: Text) ~> parseList 1
       `shouldParse` ["one", "two", "three3"]
+  describe "Should Succeed"
+    $ it "quoted list"
+    $ ("\"one\"\n two\n three3" :: Text) ~> parseList 1
+      `shouldParse` ["one", "two", "three3"]
 
 fullFile :: Text
 fullFile = "name: implicit-hie\n" <> libSection <> exeSection <> testSection