diff --git a/implicit-hie.cabal b/implicit-hie.cabal --- a/implicit-hie.cabal +++ b/implicit-hie.cabal @@ -7,7 +7,7 @@ -- hash: b2b829a658e33ea328c725dea732391089d03ffd2a216d413a75d88aefa7c181 name: implicit-hie -version: 0.1.2.7 +version: 0.1.3.0 description: Auto generate a stack or cabal multi component hie.yaml file @@ -46,15 +46,16 @@ 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 @@ , yaml default-language: Haskell2010 - + if !flag(executable) buildable: False diff --git a/src/Hie/Cabal/Parser.hs b/src/Hie/Cabal/Parser.hs --- a/src/Hie/Cabal/Parser.hs +++ b/src/Hie/Cabal/Parser.hs @@ -1,18 +1,52 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} -module Hie.Cabal.Parser where +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.Functor -import Data.Maybe -import Data.Text (Text) -import qualified Data.Text as T -import System.FilePath.Posix (()) +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 ((<.>), ()) + type Name = Text type Path = Text @@ -29,83 +63,6 @@ = 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,65 +99,28 @@ 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 @@ -208,13 +128,6 @@ 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 @@ -222,4 +135,52 @@ 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] + _ -> [] diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -14,212 +14,31 @@ spec :: Spec spec = do describe "Should Succeed" $ - it "successfully parses executable section" $ - exeSection ~> parseExe 0 - `shouldParse` [Comp Exe "gen-hie" "app/Main.hs"] - describe "Should Succeed" $ - it "successfully parses test section" $ - testSection ~> parseTestSuite 0 - `shouldParse` [Comp Test "implicit-hie-test" "test"] - describe "Should Succeed" $ - it "successfully parses library section" $ - libSection ~> parseLib 0 - `shouldParse` [Comp Lib "" "src"] - describe "Should Succeed" $ - it "successfully parses library section with 2 hs-source-dirs" $ - libSection2 ~> parseLib 0 - `shouldParse` [Comp Lib "" "src", Comp Lib "" "src2"] - describe "Should Succeed" $ - it "successfully parses library section with 2 paths under hs-source-dirs" $ - libSection3 ~> parseLib 0 - `shouldParse` [Comp Lib "" "src", Comp Lib "" "src2"] - describe "Should Succeed" $ - it "successfully parses bench section" $ - do - bs <- T.readFile "test/benchSection" - bs ~> parseBench 0 - `shouldParse` [Comp Bench "folds" "benchmarks/folds.hs"] - describe "Should Succeed" $ it "successfully parses package" $ do cf <- T.readFile "implicit-hie.cabal" - cf ~> parsePackage + parsePackage' cf `shouldParse` Package "implicit-hie" - [ Comp Lib "" "src", + [ Comp Test "implicit-hie-test" "test/Spec.hs", Comp Exe "gen-hie" "app/Main.hs", - Comp Test "implicit-hie-test" "test" + Comp Lib "" "src/Hie/Cabal/Parser.hs", + Comp Lib "" "src/Hie/Locate.hs", + Comp Lib "" "src/Hie/Yaml.hs" ] - describe "Should Succeed" $ - it - "skips to end of block section" - $ let r = "test\n" - in (libSection <> r) ~?> parseLib 0 - `leavesUnconsumed` r + describe "Should Succeed" $ it "successfully generates stack hie.yaml" $ do sf <- readFile "test/stackHie.yaml" cf <- T.readFile "implicit-hie.cabal" - (hieYaml "stack" . fmtPkgs "stack" . (: []) <$> parseOnly parsePackage cf) + (hieYaml "stack" . fmtPkgs "stack" . (: []) <$> parsePackage' cf) `shouldBe` Right sf + describe "Should Succeed" $ it "successfully generates cabal hie.yaml for haskell-language-server" $ do f <- T.readFile "test/haskell-language-server-cabal" o <- readFile "test/hie.yaml.cbl" - (hieYaml "cabal" . fmtPkgs "cabal" . (: []) <$> parseOnly parsePackage f) + (hieYaml "cabal" . fmtPkgs "cabal" . (: []) <$> parsePackage' f) `shouldBe` Right o - describe "Should Succeed" $ - it "successfully parses comma list" $ - ("one, two" :: Text) ~> parseList 1 `shouldParse` ["one", "two"] - describe "Should Succeed" $ - it "successfully parses newline list" $ - ("one\n two \n three3" :: Text) ~> parseList 1 - `shouldParse` ["one", "two", "three3"] - describe "Should Succeed" $ - 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"] - describe "Should Succeed" $ - it "list with leading commas" $ - ("one\n , two\n , three3" :: Text) ~> parseList 1 - `shouldParse` ["one", "two", "three3"] - describe "Should Succeed" $ - it "list with a comment" $ - ("foo\n -- need to include this too\n bar\n" :: Text) ~> parseList 1 - `shouldParse` ["foo", "bar"] - describe "Should Succeed" $ - it "list2 with a comment" $ - ("foo -- need to include this too\n bar\n" :: Text) ~> parseList 1 - `shouldParse` ["foo", "bar"] - describe "Should Succeed" $ - it "list3 with a comment" $ - ("foo -- need to include this too\n bar" :: Text) ~> parseList 1 - `shouldParse` ["foo", "bar"] - describe "Should Succeed" $ - it "list4 with a comment" $ - ("foo\n bar\n -- need to include this too" :: Text) ~> parseList 1 - `shouldParse` ["foo", "bar"] - describe "Should Succeed" $ - it "list5 with a comment" $ - ("foo\n bar -- need to include this too" :: Text) ~> parseList 1 - `shouldParse` ["foo", "bar"] - describe "Should Succeed" $ - it "succesfully parses exe component with other-modules containing dots" $ - exeSection2 ~> parseExe 0 - `shouldParse` [ Comp Exe "gen-hie" "app/Main.hs", - Comp Exe "gen-hie" "app/Hie/Executable/Helper.hs", - Comp Exe "gen-hie" "app/Hie/Executable/Utils.hs" - ] - describe "Should Succeed" $ - it "succesfully parses single other-modules" $ - ("other-modules: test\ndefault-language: Haskell2011" :: Text) ~?> field 0 "other-modules" parseList - `leavesUnconsumed` "default-language: Haskell2011" - describe "Should Succeed" $ - it "succesfully parses empty other-modules1" $ - ("other-modules: test\ndefault-language: Haskell2011" :: Text) ~?> field 0 "other-modules" parseList - `leavesUnconsumed` "default-language: Haskell2011" - describe "Should Succeed" $ - it "succesfully parses empty other-modules2" $ - (" other-modules: \n build-depends:\n base >=4.9 && <5" :: Text) ~> field 0 "other-modules" parseList - `shouldParse` [] - -exeSection :: Text -exeSection = - "executable gen-hie\n\ - \ other-modules:\n\ - \ Paths_implicit_hie\n\ - \ autogen-modules:\n\ - \ Paths_implicit_hie\n\ - \ hs-source-dirs:\n\ - \ app\n\ - \ ghc-options: -O2\n\ - \ main-is: Main.hs \n" - -testSection :: Text -testSection = - "test-suite implicit-hie-test\n\ - \ type: exitcode-stdio-1.0\n\ - \ other-modules:\n\ - \ Paths_implicit_hie\n\ - \ hs-source-dirs:\n\ - \ test\n\ - \ ghc-options: -fspecialize-aggressively -Wall -Wincomplete-record-updates -Wincomplete-uni-patterns -fno-warn-unused-imports -fno-warn-unused-binds -fno-warn-name-shadowing -fwarn-redundant-constraints -threaded -rtsopts -with-rtsopts=-N\n\ - \ main-is: Spec.hs\n\ - \ build-depends:\n\ - \ attoparsec\n\ - \ , base >=4.7 && <5\n\ - \ , hspec\n\ - \ , hspec-attoparsec\n\ - \ , implicit-hie\n\ - \ , text\n\ - \ default-language: Haskell2010\n" - -libSection :: Text -libSection = - "library\n\ - \ exposed-modules:\n\ - \ Lib\n\ - \ other-modules:\n\ - \ Paths_implicit_hie\n\ - \ hs-source-dirs:\n\ - \ src\n\ - \ ghc-options: -fspecialize-aggressively -Wall -Wincomplete-record-updates -Wincomplete-uni-patterns -fno-warn-unused-imports -fno-warn-unused-binds -fno-warn-name-shadowing -fwarn-redundant-constraints\n\ - \ build-depends:\n\ - \ attoparsec\n\ - \ , base >=4.7 && <5\n\ - \ , text\n\ - \ default-language: Haskell2010\n\ - \" - -libSection2 :: Text -libSection2 = - "library\n\ - \ exposed-modules:\n\ - \ Lib\n\ - \ other-modules:\n\ - \ Paths_implicit_hie\n\ - \ hs-source-dirs:\n\ - \ src\n\ - \ hs-source-dirs:\n\ - \ src2\n\ - \ ghc-options: -fspecialize-aggressively -Wall -Wincomplete-record-updates -Wincomplete-uni-patterns -fno-warn-unused-imports -fno-warn-unused-binds -fno-warn-name-shadowing -fwarn-redundant-constraints\n\ - \ build-depends:\n\ - \ attoparsec\n\ - \ , base >=4.7 && <5\n\ - \ , text\n\ - \ default-language: Haskell2010\n\ - \" - -libSection3 :: Text -libSection3 = - "library\n\ - \ exposed-modules:\n\ - \ Lib\n\ - \ other-modules:\n\ - \ Paths_implicit_hie\n\ - \ hs-source-dirs:\n\ - \ src,\n\ - \ src2\n\ - \ ghc-options: -fspecialize-aggressively -Wall -Wincomplete-record-updates -Wincomplete-uni-patterns -fno-warn-unused-imports -fno-warn-unused-binds -fno-warn-name-shadowing -fwarn-redundant-constraints\n\ - \ build-depends:\n\ - \ attoparsec\n\ - \ , base >=4.7 && <5\n\ - \ , text\n\ - \ default-language: Haskell2010\n\ - \" - -exeSection2 :: Text -exeSection2 = - "executable gen-hie\n\ - \ other-modules:\n\ - \ Hie.Executable.Helper\n\ - \ Hie.Executable.Utils\n\ - \ hs-source-dirs:\n\ - \ app\n\ - \ main-is: Main.hs \n" diff --git a/test/benchSection b/test/benchSection --- a/test/benchSection +++ b/test/benchSection @@ -1,3 +1,6 @@ +name: folds-test +version: 0.1 + benchmark folds default-language: Haskell2010 hs-source-dirs: benchmarks diff --git a/test/hie.yaml.cbl b/test/hie.yaml.cbl --- a/test/hie.yaml.cbl +++ b/test/hie.yaml.cbl @@ -1,22 +1,2 @@ cradle: cabal: - - path: "src" - component: "lib:haskell-language-server" - - - path: "exe/Main.hs" - component: "haskell-language-server:exe:haskell-language-server" - - - path: "exe/Arguments.hs" - component: "haskell-language-server:exe:haskell-language-server" - - - path: "exe/Wrapper.hs" - component: "haskell-language-server:exe:haskell-language-server-wrapper" - - - path: "exe/Arguments.hs" - component: "haskell-language-server:exe:haskell-language-server-wrapper" - - - path: "test/functional" - component: "haskell-language-server:test:func-test" - - - path: "test/utils" - component: "haskell-language-server:lib:hls-test-utils" diff --git a/test/stackHie.yaml b/test/stackHie.yaml --- a/test/stackHie.yaml +++ b/test/stackHie.yaml @@ -1,10 +1,16 @@ cradle: stack: - - path: "src" - component: "implicit-hie:lib" + - path: "test/Spec.hs" + component: "implicit-hie:test:implicit-hie-test" - path: "app/Main.hs" component: "implicit-hie:exe:gen-hie" - - path: "test" - component: "implicit-hie:test:implicit-hie-test" + - path: "src/Hie/Cabal/Parser.hs" + component: "implicit-hie:lib" + + - path: "src/Hie/Locate.hs" + component: "implicit-hie:lib" + + - path: "src/Hie/Yaml.hs" + component: "implicit-hie:lib"