{-# LANGUAGE ViewPatterns, PatternGuards, TupleSections, RecordWildCards, ScopedTypeVariables #-}
module Input.Cabal(
PkgName, Package(..),
parseCabalTarball, readGhcPkg,
packagePopularity, readCabal
) where
import Input.Settings
import Data.List.Extra
import System.FilePath
import Control.DeepSeq
import Control.Exception
import Control.Exception.Extra
import Control.Monad
import System.IO.Extra
import General.Str
import System.Exit
import qualified System.Process.ByteString as BS
import qualified Data.ByteString.UTF8 as UTF8
import System.Directory
import Data.Char
import Data.Maybe
import Data.Tuple.Extra
import qualified Data.Map.Strict as Map
import General.Util
import General.Conduit
import Data.Semigroup
import Control.Applicative
import Prelude
data Package = Package
{packageTags :: ![(Str, Str)]
,packageLibrary :: !Bool
,packageSynopsis :: !Str
,packageVersion :: !Str
,packageDepends :: ![PkgName]
,packageDocs :: !(Maybe FilePath)
} deriving Show
instance Semigroup Package where
Package x1 x2 x3 x4 x5 x6 <> Package y1 y2 y3 y4 y5 y6 =
Package (x1++y1) (x2||y2) (one x3 y3) (one x4 y4) (nubOrd $ x5 ++ y5) (x6 `mplus` y6)
where one a b = if strNull a then b else a
instance Monoid Package where
mempty = Package [] True mempty mempty [] Nothing
mappend = (<>)
instance NFData Package where
rnf (Package a b c d e f) = rnf (a,b,c,d,e,f)
packagePopularity :: Map.Map PkgName Package -> ([String], Map.Map PkgName Int)
packagePopularity cbl = mp `seq` (errs, mp)
where
mp = Map.map length good
errs = [ strUnpack user ++ ".cabal: Import of non-existant package " ++ strUnpack name ++
(if null rest then "" else ", also imported by " ++ show (length rest) ++ " others")
| (name, user:rest) <- Map.toList bad]
(good, bad) = Map.partitionWithKey (\k _ -> k `Map.member` cbl) $
Map.fromListWith (++) [(b,[a]) | (a,bs) <- Map.toList cbl, b <- packageDepends bs]
readGhcPkg :: Settings -> IO (Map.Map PkgName Package)
readGhcPkg settings = do
topdir <- findExecutable "ghc-pkg"
(exit, stdout, stderr) <- BS.readProcessWithExitCode "ghc-pkg" ["dump"] mempty
when (exit /= ExitSuccess) $
errorIO $ "Error when reading from ghc-pkg, " ++ show exit ++ "\n" ++ UTF8.toString stderr
let g (stripPrefix "$topdir" -> Just x) | Just t <- topdir = takeDirectory t ++ x
g x = x
let fixer p = p{packageLibrary = True, packageDocs = g <$> packageDocs p}
let f ((stripPrefix "name: " -> Just x):xs) = Just (strPack x, fixer $ readCabal settings $ unlines xs)
f xs = Nothing
return $ Map.fromList $ mapMaybe f $ splitOn ["---"] $ lines $ filter (/= '\r') $ UTF8.toString stdout
parseCabalTarball :: Settings -> FilePath -> IO (Map.Map PkgName Package)
parseCabalTarball settings tarfile = do
res <- runConduit $
(sourceList =<< liftIO (tarballReadFiles tarfile)) .|
mapC (first takeBaseName) .| groupOnLastC fst .| mapMC (evaluate . force) .|
pipelineC 10 (mapC (strPack *** readCabal settings . lbstrUnpack) .| mapMC (evaluate . force) .| sinkList)
return $ Map.fromList res
readCabal :: Settings -> String -> Package
readCabal Settings{..} src = Package{..}
where
mp = Map.fromListWith (++) $ lexCabal src
ask x = Map.findWithDefault [] x mp
packageDepends =
map strPack $ nubOrd $ filter (/= "") $
map (intercalate "-" . takeWhile (all isAlpha . take 1) . splitOn "-" . fst . word1) $
concatMap (split (== ',')) (ask "build-depends") ++ concatMap words (ask "depends")
packageVersion = strPack $ head $ dropWhile null (ask "version") ++ ["0.0"]
packageSynopsis = strPack $ unwords $ words $ unwords $ ask "synopsis"
packageLibrary = "library" `elem` map (lower . trim) (lines src)
packageDocs = listToMaybe $ ask "haddock-html"
packageTags = map (both strPack) $ nubOrd $ concat
[ map (head xs,) $ concatMap cleanup $ concatMap ask xs
| xs <- [["license"],["category"],["author","maintainer"]]]
cleanup =
filter (/= "") .
map (renameTag . intercalate "-" . filter ('@' `notElem`) . words . takeWhile (`notElem` "<(")) .
concatMap (map unwords . split (== "and") . words) . split (`elem` ",&")
lexCabal :: String -> [(String, [String])]
lexCabal = f . lines
where
f (x:xs) | (white,x) <- span isSpace x
, (name@(_:_),x) <- span (\c -> isAlpha c || c == '-') x
, ':':x <- trim x
, (xs1,xs2) <- span (\s -> length (takeWhile isSpace s) > length white) xs
= (lower name, trim x : replace ["."] [""] (map (trim . fst . breakOn "--") xs1)) : f xs2
f (x:xs) = f xs
f [] = []