Use Cabal-syntax to parse cabal packages

implicit-hie.cabal

@@ -46,15 +46,16 @@ library
   hs-source-dirs:   src
   ghc-options:
     -Wall -Wincomplete-record-updates -Wincomplete-uni-patterns
-    -fno-warn-unused-imports -fno-warn-unused-binds
     -fno-warn-name-shadowing -fwarn-redundant-constraints
 
   build-depends:
       attoparsec    >=0.13
     , base          >=4.7  && <5
+    , bytestring
     , directory     >=1.3
     , filepath      >=1.4
     , filepattern   >=0.1
+    , Cabal-syntax  >=3.8
     , text          >=1.2
     , transformers  >=0.5
     , yaml          >=0.5
@@ -88,7 +89,7 @@ executable gen-hie
     , yaml
 
   default-language: Haskell2010
-  
+
   if !flag(executable)
     buildable: False
 

src/Hie/Cabal/Parser.hs

@@ -1,17 +1,51 @@
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
+
+module Hie.Cabal.Parser
+( Package(..)
+, Component(..)
+, CompType(..)
+, Name
+, extractPkgs
+, parsePackage'
+) where
+
+import           Control.Applicative
+import           Control.Monad
+import           Data.Attoparsec.Text
+import           Data.Char
+import           Data.Foldable                                 (asum)
+import           Data.Maybe                                    (catMaybes,
+                                                                maybeToList)
+import           Data.Text                                     (Text)
+import qualified Data.Text                                     as T
+import           Data.Text.Encoding                            (encodeUtf8)
+import           Distribution.ModuleName                       (ModuleName,
+                                                                toFilePath)
+import           Distribution.Package                          (pkgName,
+                                                                unPackageName)
+import           Distribution.PackageDescription               (Benchmark (benchmarkBuildInfo, benchmarkInterface, benchmarkName),
+                                                                BenchmarkInterface (BenchmarkExeV10),
+                                                                Executable (buildInfo, exeName, modulePath),
+                                                                ForeignLib (foreignLibBuildInfo, foreignLibName),
+                                                                Library (libBuildInfo, libName),
+                                                                LibraryName (..),
+                                                                TestSuiteInterface (TestSuiteExeV10),
+                                                                benchmarkModules,
+                                                                exeModules,
+                                                                explicitLibModules,
+                                                                foreignLibModules)
+import           Distribution.PackageDescription.Configuration
+import           Distribution.PackageDescription.Parsec
+import           Distribution.Types.BuildInfo
+import           Distribution.Types.PackageDescription
+import           Distribution.Types.TestSuite
+import           Distribution.Types.UnqualComponentName
+import           Distribution.Utils.Path                       (getSymbolicPath)
+import           GHC.IO                                        (unsafePerformIO)
+import           System.Directory                              (doesFileExist)
+import           System.FilePath                               ((<.>), (</>))
 
-module Hie.Cabal.Parser where
-
-import Control.Applicative
-import Control.Monad
-import Data.Attoparsec.Text
-import Data.Char
-import Data.Functor
-import Data.Maybe
-import Data.Text (Text)
-import qualified Data.Text as T
-import System.FilePath.Posix ((</>))
 
 type Name = Text
 
@@ -29,83 +63,6 @@ data Component
   = Comp CompType Name Path
   deriving (Show, Eq, Ord)
 
-parsePackage' :: Text -> Either String Package
-parsePackage' = parseOnly parsePackage
-
--- Skip over entire fields that are known to be free-form.  Ensures lines that
--- look like the beginning of sections/stanzas are not inadvertently intepreted
--- as such.
--- List gathered by searching "free text field" in:
--- https://cabal.readthedocs.io/en/3.4/buildinfo-fields-reference.html
--- May be subject to change across Cabal versions.
-skipFreeformField :: Parser ()
-skipFreeformField =
-  choice $
-    flip (field 0) skipBlock
-      <$> [ "author",
-            "bug-reports",
-            "category",
-            "copyright",
-            "description",
-            "homepage",
-            "maintainer",
-            "package-url",
-            "stability",
-            "synopsis"
-          ]
-
-parsePackage :: Parser Package
-parsePackage =
-  ( do
-      n <- field 0 "name" $ const parseString
-      (Package _ t) <- parsePackage
-      pure $ Package n t
-  )
-    <|> (skipFreeformField >> parsePackage)
-    <|> ( do
-            h <- parseComponent 0
-            (Package n t) <- parsePackage
-            pure $ Package n (h <> t)
-        )
-    <|> (skipToNextLine >> parsePackage)
-    <|> pure (Package "" [])
-
-componentHeader :: Indent -> Text -> Parser Name
-componentHeader i t = do
-  _ <- indent i
-  _ <- asciiCI t
-  skipMany tabOrSpace
-  n <- parseString <|> pure ""
-  skipToNextLine
-  pure n
-
-parseComponent :: Indent -> Parser [Component]
-parseComponent i =
-  parseExe i
-    <|> parseLib i
-    <|> parseBench i
-    <|> parseTestSuite i
-
-parseLib :: Indent -> Parser [Component]
-parseLib i =
-  (parseSec i "library" $ Comp Lib)
-    <|> (parseSec i "foreign-library" $ Comp Lib)
-
-parseTestSuite :: Indent -> Parser [Component]
-parseTestSuite i = parseSec i "test-suite" $ Comp Test
-
-parseExe :: Indent -> Parser [Component]
-parseExe = parseSecMain (Comp Exe) "executable"
-
-parseBench :: Indent -> Parser [Component]
-parseBench = parseSecMain (Comp Bench) "benchmark"
-
-parseSecMain :: (Name -> Path -> Component) -> Text -> Indent -> Parser [Component]
-parseSecMain c s i = do
-  n <- componentHeader i s
-  p <- pathMain (i + 1) ["./"] "" [] []
-  pure $ map (c n) p
-
 parseQuoted :: Parser Text
 parseQuoted = do
   q <- char '"' <|> char '\''
@@ -142,84 +99,88 @@ parseList i = many (nl <|> sl)
       skipMany com
       pure x
 
-pathMain :: Indent -> [Text] -> Text -> [Text] -> [Text] -> Parser [Text]
-pathMain i p m o a =
-  (hsSourceDir i >>= (\p' -> pathMain i p' m o a))
-    <|> (field i "main-is" (const parseString) >>= (\m' -> pathMain i p m' o a))
-    <|> (field i "other-modules" parseList >>= flip (pathMain i p m) a)
-    <|> (field i "autogen-modules" parseList >>= pathMain i p m o)
-    <|> (skipBlockLine i >> pathMain i p m o a)
-    <|> pure
-      ( map (<//> m) p
-          <> [ p' <//> (o'' <> ".hs")
-               | p' <- p,
-                 o' <- filter (`notElem` a) o,
-                 let o'' = T.replace "." "/" o'
-             ]
-      )
-
-(<//>) :: Text -> Text -> Text
-a <//> b = T.pack (T.unpack a </> T.unpack b)
-
-infixr 5 <//>
-
-parseSec :: Indent -> Text -> (Name -> Path -> Component) -> Parser [Component]
-parseSec i compType compCon = do
-  n <- componentHeader i compType
-  p <- extractPath (i + 1) []
-  let p' = if null p then ["./"] else p
-  pure $ map (compCon n) p'
-
 skipToNextLine :: Parser ()
 skipToNextLine = skipWhile (not . isEndOfLine) >> endOfLine
 
-skipBlock :: Indent -> Parser ()
-skipBlock i = skipMany $ skipBlockLine i
-
 comment :: Parser ()
 comment = skipMany tabOrSpace >> "--" >> skipToNextLine
 
-skipBlockLine :: Indent -> Parser ()
-skipBlockLine i = (indent i >> skipToNextLine) <|> emptyOrComLine
-
 emptyOrComLine :: Parser ()
 emptyOrComLine = (skipMany tabOrSpace >> endOfLine) <|> comment
 
 tabOrSpace :: Parser Char
 tabOrSpace = char ' ' <|> char '\t'
 
-hsSourceDir :: Indent -> Parser [Text]
-hsSourceDir i = field i "hs-source-dirs" parseList
-
 -- field :: Indent -> Text -> Parser Text
 field ::
   Indent ->
-  Text ->
+  [Text] ->
   (Indent -> Parser a) ->
   Parser a
 field i f p =
   do
     i' <- indent i
-    _ <- asciiCI f
+    _ <- asum $ map asciiCI f
     skipMany tabOrSpace
     _ <- char ':'
     skipMany tabOrSpace
     p' <- p $ i' + 1
     skipToNextLine
     pure p'
 
-extractPath :: Indent -> [Path] -> Parser [Path]
-extractPath i ps =
-  (field i "hs-source-dirs" parseList >>= (\p -> extractPath i $ ps <> p))
-    <|> (skipBlockLine i >> extractPath i ps)
-    <|> (comment >> extractPath i ps)
-    <|> pure ps
-
 -- | Skip at least n spaces
 indent :: Indent -> Parser Int
 indent i = do
   c <- length <$> many' tabOrSpace
   if c >= i then pure c else fail "insufficient indent"
 
 extractPkgs :: Parser [T.Text]
-extractPkgs = join . catMaybes <$> many' (Just <$> field 0 "packages" parseList <|> (skipToNextLine >> pure Nothing))
+extractPkgs = join . catMaybes <$> many' (Just <$> field 0 ["packages"] parseList <|> (skipToNextLine >> pure Nothing))
+
+parsePackage' :: T.Text -> Either String Package
+parsePackage' t = do
+  let bytes = encodeUtf8 t
+  case runParseResult (parseGenericPackageDescription bytes) of
+    (_warnings, Left err) ->
+        error $ "Cannot parse Cabal file: " <> show err
+    (_warnings, Right res) -> do
+      let pkg = flattenPackageDescription res
+      Right $ extractPackage pkg
+
+extractPackage :: PackageDescription -> Package
+extractPackage PackageDescription{..} = Package n cc where
+  n = T.pack . unPackageName $ pkgName package
+
+  cc = concat $
+    [mkComp Test (unqName $ testName t) (testBuildInfo t) (testExePath t) (testModules t) | t <- testSuites] ++
+    [mkComp Bench (unqName $ benchmarkName b) (benchmarkBuildInfo b) (benchmarkExePath b) (benchmarkModules b) | b <- benchmarks] ++
+    [mkComp Exe (unqName $ exeName e) (buildInfo e) [modulePath e] (exeModules e) | e <- executables] ++
+    [mkComp Lib (libName' l) (libBuildInfo l) [] (explicitLibModules l) | l <- maybeToList library ++ subLibraries ] ++
+    [mkComp Lib (unqName $ foreignLibName f) (foreignLibBuildInfo f) [] (foreignLibModules f) | f <- foreignLibs]
+
+  mkComp :: CompType -> T.Text -> BuildInfo -> [FilePath] -> [ModuleName] -> [Component]
+  mkComp typ name bi fps mods =
+    [Comp typ name (T.pack fp)
+    | fp0 <- fps <> concatMap toFilePath' mods
+    , srcDir <- map getSymbolicPath $ hsSourceDirs bi
+    , let fp = srcDir </> fp0
+    , unsafePerformIO $ doesFileExist fp
+    ]
+
+  unqName = T.pack . unUnqualComponentName
+  libName' x = case libName x of
+    LMainLibName  -> ""
+    LSubLibName u -> unqName u
+
+benchmarkExePath :: Benchmark -> [FilePath]
+benchmarkExePath b = case benchmarkInterface b of
+  BenchmarkExeV10 _ f -> [f]
+  _                   -> []
+
+toFilePath' :: ModuleName -> [FilePath]
+toFilePath' mod = [ toFilePath mod <.> ext | ext <- ["hs", "lhs"]]
+
+testExePath :: TestSuite -> [FilePath]
+testExePath t = case testInterface t of
+    TestSuiteExeV10 _ fp -> [fp]
+    _                    -> []