From 7f8f1f0d64021acd07d9000327d819f471391fc6 Mon Sep 17 00:00:00 2001 From: Maxim Koltsov Date: Sat, 6 Jun 2020 01:44:59 +0300 Subject: [PATCH] WIP use cabal-install-parsers --- app/Main.hs | 8 +-- implicit-hie.cabal | 2 + src/Hie/Locate.hs | 123 ++++++++++++++++++++++++++------------------- 3 files changed, 76 insertions(+), 57 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 361e09e..3971a64 100644 --- a/app/Main.hs +++ b/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 diff --git a/implicit-hie.cabal b/implicit-hie.cabal index d04bd47..2bfbed9 100644 --- a/implicit-hie.cabal +++ b/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 diff --git a/src/Hie/Locate.hs b/src/Hie/Locate.hs index 57bbcb5..c1226c9 100644 --- a/src/Hie/Locate.hs +++ b/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