{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, FlexibleContexts #-}

module IHaskell.BrokenPackages (getBrokenPackages) where

import           IHaskellPrelude
import qualified Data.Text as T

import           Text.Parsec
import           Text.Parsec.String

import           Shelly

data BrokenPackage = BrokenPackage String [String]

instance Show BrokenPackage where
  show :: BrokenPackage -> String
show (BrokenPackage String
packageID [String]
_) = String
packageID

-- | Get a list of broken packages. This function internally shells out to `ghc-pkg`, and parses the
-- output in order to determine what packages are broken.
getBrokenPackages :: IO [String]
getBrokenPackages :: IO [String]
getBrokenPackages = Sh [String] -> IO [String]
forall (m :: * -> *) a. MonadIO m => Sh a -> m a
shelly (Sh [String] -> IO [String]) -> Sh [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ do
  Text
_ <- Sh Text -> Sh Text
forall a. Sh a -> Sh a
silently (Sh Text -> Sh Text) -> Sh Text -> Sh Text
forall a b. (a -> b) -> a -> b
$ Bool -> Sh Text -> Sh Text
forall a. Bool -> Sh a -> Sh a
errExit Bool
False (Sh Text -> Sh Text) -> Sh Text -> Sh Text
forall a b. (a -> b) -> a -> b
$ String -> [Text] -> Sh Text
run String
"ghc-pkg" [Text
"check"]
  Text
checkOut <- Sh Text
lastStderr

  -- Get rid of extraneous things
  let rightStart :: String -> Bool
rightStart String
str = String
"There are problems" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
str Bool -> Bool -> Bool
||
                       String
"  dependency" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
str
      ghcPkgOutput :: String
ghcPkgOutput = [String] -> String
unlines ([String] -> String) -> (String -> [String]) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
rightStart ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
checkOut

  [String] -> Sh [String]
forall a. a -> Sh a
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> Sh [String]) -> [String] -> Sh [String]
forall a b. (a -> b) -> a -> b
$
    case Parsec String () [BrokenPackage]
-> String -> String -> Either ParseError [BrokenPackage]
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse (ParsecT String () Identity BrokenPackage
-> Parsec String () [BrokenPackage]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT String () Identity BrokenPackage
check) String
"ghc-pkg output" String
ghcPkgOutput of
      Left ParseError
_     -> []
      Right [BrokenPackage]
pkgs -> (BrokenPackage -> String) -> [BrokenPackage] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map BrokenPackage -> String
forall a. Show a => a -> String
show [BrokenPackage]
pkgs

check :: Parser BrokenPackage
check :: ParsecT String () Identity BrokenPackage
check = String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"There are problems in package "
        ParsecT String () Identity String
-> ParsecT String () Identity BrokenPackage
-> ParsecT String () Identity BrokenPackage
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> [String] -> BrokenPackage
BrokenPackage (String -> [String] -> BrokenPackage)
-> ParsecT String () Identity String
-> ParsecT String () Identity ([String] -> BrokenPackage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity String
ident ParsecT String () Identity ([String] -> BrokenPackage)
-> ParsecT String () Identity String
-> ParsecT String () Identity ([String] -> BrokenPackage)
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
":\n" ParsecT String () Identity ([String] -> BrokenPackage)
-> ParsecT String () Identity [String]
-> ParsecT String () Identity BrokenPackage
forall a b.
ParsecT String () Identity (a -> b)
-> ParsecT String () Identity a -> ParsecT String () Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT String () Identity String
-> ParsecT String () Identity [String]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT String () Identity String
dependency

ident :: Parser String
ident :: ParsecT String () Identity String
ident = ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
alphaNum ParsecT String () Identity Char
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
"-.")

dependency :: Parser String
dependency :: ParsecT String () Identity String
dependency = String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"  dependency \"" ParsecT String () Identity String
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT String () Identity String
ident ParsecT String () Identity String
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"\" doesn't exist\n"