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.3.0 +version: 0.1.4.0 description: Auto generate a stack or cabal multi component hie.yaml file @@ -46,16 +46,15 @@ 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 @@ -89,7 +88,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,51 +1,17 @@ +{-# 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 @@ -63,6 +29,83 @@ = 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 '\'' @@ -99,28 +142,65 @@ 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 - _ <- asum $ map asciiCI f + _ <- asciiCI f skipMany tabOrSpace _ <- char ':' skipMany tabOrSpace @@ -128,6 +208,13 @@ 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 @@ -135,52 +222,4 @@ 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)) - -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] - _ -> [] +extractPkgs = join . catMaybes <$> many' (Just <$> field 0 "packages" parseList <|> (skipToNextLine >> pure Nothing)) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -14,31 +14,212 @@ 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" - parsePackage' cf + cf ~> parsePackage `shouldParse` Package "implicit-hie" - [ Comp Test "implicit-hie-test" "test/Spec.hs", + [ Comp Lib "" "src", Comp Exe "gen-hie" "app/Main.hs", - Comp Lib "" "src/Hie/Cabal/Parser.hs", - Comp Lib "" "src/Hie/Locate.hs", - Comp Lib "" "src/Hie/Yaml.hs" + Comp Test "implicit-hie-test" "test" ] - 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" . (: []) <$> parsePackage' cf) + (hieYaml "stack" . fmtPkgs "stack" . (: []) <$> parseOnly 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" . (: []) <$> parsePackage' f) + (hieYaml "cabal" . fmtPkgs "cabal" . (: []) <$> parseOnly 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,6 +1,3 @@ -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,2 +1,22 @@ 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,16 +1,10 @@ cradle: stack: - - path: "test/Spec.hs" - component: "implicit-hie:test:implicit-hie-test" + - path: "src" + component: "implicit-hie:lib" - path: "app/Main.hs" component: "implicit-hie:exe:gen-hie" - - 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" + - path: "test" + component: "implicit-hie:test:implicit-hie-test"