mirror of
https://github.com/Avi-D-coder/implicit-hie.git
synced 2024-11-26 00:04:23 +03:00
Use Cabal-syntax to parse cabal packages
This commit is contained in:
Pepe Iborra
parent
fa0c5b28f6
commit
4a0da1c2a4
@ -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
|
||||
|
||||
|
||||
@ -1,17 +1,46 @@
|
||||
{-# 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.Foldable (asum)
|
||||
import Data.Maybe (maybeToList, catMaybes)
|
||||
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, benchmarkName),
|
||||
Executable (buildInfo, exeName),
|
||||
ForeignLib (foreignLibBuildInfo, foreignLibName),
|
||||
Library (libBuildInfo, libName),
|
||||
LibraryName (..),
|
||||
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 System.FilePath ((</>))
|
||||
|
||||
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 +58,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,65 +94,28 @@ 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
|
||||
@ -208,13 +123,6 @@ field i f p =
|
||||
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 +130,37 @@ indent i = do
|
||||
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) (testModules t) | t <- testSuites] ++
|
||||
[mkComp Bench (unqName $ benchmarkName b) (benchmarkBuildInfo b) (benchmarkModules b) | b <- benchmarks] ++
|
||||
[mkComp Exe (unqName $ exeName e) (buildInfo 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 -> [ModuleName] -> [Component]
|
||||
mkComp typ name bi mods =
|
||||
[Comp typ name (T.pack $ srcDir </> m)
|
||||
| m <- map toFilePath mods
|
||||
, srcDir <- map getSymbolicPath $ hsSourceDirs bi
|
||||
]
|
||||
|
||||
unqName = T.pack . unUnqualComponentName
|
||||
libName' x = case libName x of
|
||||
LMainLibName -> ""
|
||||
LSubLibName u -> unqName u
|
||||
|
||||
Loading…
Reference in New Issue
Block a user