{-# LANGUAGE OverloadedStrings #-}

module Distribution.Cab.VerDB (
  -- * Types
    PkgName
  , VerDB
  , HowToObtain(..)
  -- * Creating
  , getVerDB
  -- * Converting
  , toList
  , toMap
  ) where

import Control.Applicative
import Control.Arrow (second)
import Control.Monad.Trans.Resource (runResourceT)
import Data.Attoparsec.ByteString.Char8
import Data.Conduit.Attoparsec
import Data.Conduit.Process
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe
import Distribution.Cab.Version

----------------------------------------------------------------

type PkgName = String

type VerInfo = (PkgName, Maybe [Int])

newtype VerDB = VerDB [(PkgName,Ver)] deriving (VerDB -> VerDB -> Bool
(VerDB -> VerDB -> Bool) -> (VerDB -> VerDB -> Bool) -> Eq VerDB
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: VerDB -> VerDB -> Bool
$c/= :: VerDB -> VerDB -> Bool
== :: VerDB -> VerDB -> Bool
$c== :: VerDB -> VerDB -> Bool
Eq, Int -> VerDB -> ShowS
[VerDB] -> ShowS
VerDB -> String
(Int -> VerDB -> ShowS)
-> (VerDB -> String) -> ([VerDB] -> ShowS) -> Show VerDB
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [VerDB] -> ShowS
$cshowList :: [VerDB] -> ShowS
show :: VerDB -> String
$cshow :: VerDB -> String
showsPrec :: Int -> VerDB -> ShowS
$cshowsPrec :: Int -> VerDB -> ShowS
Show)

data HowToObtain = InstalledOnly | AllRegistered

----------------------------------------------------------------

getVerDB :: HowToObtain -> IO VerDB
getVerDB :: HowToObtain -> IO VerDB
getVerDB HowToObtain
how = [(String, Ver)] -> VerDB
VerDB ([(String, Ver)] -> VerDB)
-> ((ExitCode, [(String, Maybe [Int])]) -> [(String, Ver)])
-> (ExitCode, [(String, Maybe [Int])])
-> VerDB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ExitCode, [(String, Maybe [Int])]) -> [(String, Ver)]
forall a a. (a, [(a, Maybe [Int])]) -> [(a, Ver)]
justOnly ((ExitCode, [(String, Maybe [Int])]) -> VerDB)
-> IO (ExitCode, [(String, Maybe [Int])]) -> IO VerDB
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (ExitCode, [(String, Maybe [Int])])
verInfos
  where
    script :: String
script = case HowToObtain
how of
        HowToObtain
InstalledOnly -> String
"cabal list --installed"
        HowToObtain
AllRegistered -> String
"cabal list"
    verInfos :: IO (ExitCode, [(String, Maybe [Int])])
verInfos = ResourceT IO (ExitCode, [(String, Maybe [Int])])
-> IO (ExitCode, [(String, Maybe [Int])])
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (ResourceT IO (ExitCode, [(String, Maybe [Int])])
 -> IO (ExitCode, [(String, Maybe [Int])]))
-> ResourceT IO (ExitCode, [(String, Maybe [Int])])
-> IO (ExitCode, [(String, Maybe [Int])])
forall a b. (a -> b) -> a -> b
$ String
-> ConduitT ByteString Void (ResourceT IO) [(String, Maybe [Int])]
-> ResourceT IO (ExitCode, [(String, Maybe [Int])])
forall (m :: * -> *) a.
MonadIO m =>
String -> ConduitT ByteString Void m a -> m (ExitCode, a)
sourceCmdWithConsumer String
script ConduitT ByteString Void (ResourceT IO) [(String, Maybe [Int])]
forall o.
ConduitT ByteString o (ResourceT IO) [(String, Maybe [Int])]
cabalListParser
    justOnly :: (a, [(a, Maybe [Int])]) -> [(a, Ver)]
justOnly = ((a, Maybe [Int]) -> (a, Ver)) -> [(a, Maybe [Int])] -> [(a, Ver)]
forall a b. (a -> b) -> [a] -> [b]
map ((Maybe [Int] -> Ver) -> (a, Maybe [Int]) -> (a, Ver)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ([Int] -> Ver
toVer ([Int] -> Ver) -> (Maybe [Int] -> [Int]) -> Maybe [Int] -> Ver
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe [Int] -> [Int]
forall a. HasCallStack => Maybe a -> a
fromJust)) ([(a, Maybe [Int])] -> [(a, Ver)])
-> ((a, [(a, Maybe [Int])]) -> [(a, Maybe [Int])])
-> (a, [(a, Maybe [Int])])
-> [(a, Ver)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, Maybe [Int]) -> Bool)
-> [(a, Maybe [Int])] -> [(a, Maybe [Int])]
forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe [Int] -> Bool
forall a. Maybe a -> Bool
isJust (Maybe [Int] -> Bool)
-> ((a, Maybe [Int]) -> Maybe [Int]) -> (a, Maybe [Int]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Maybe [Int]) -> Maybe [Int]
forall a b. (a, b) -> b
snd) ([(a, Maybe [Int])] -> [(a, Maybe [Int])])
-> ((a, [(a, Maybe [Int])]) -> [(a, Maybe [Int])])
-> (a, [(a, Maybe [Int])])
-> [(a, Maybe [Int])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, [(a, Maybe [Int])]) -> [(a, Maybe [Int])]
forall a b. (a, b) -> b
snd
    cabalListParser :: ConduitT ByteString o (ResourceT IO) [(String, Maybe [Int])]
cabalListParser = Parser ByteString [(String, Maybe [Int])]
-> ConduitT ByteString o (ResourceT IO) [(String, Maybe [Int])]
forall a (m :: * -> *) b o.
(AttoparsecInput a, MonadThrow m) =>
Parser a b -> ConduitT a o m b
sinkParser Parser ByteString [(String, Maybe [Int])]
verinfos

----------------------------------------------------------------

-- | Converting 'VerDB' to alist.
--
-- >>> db <- getVerDB InstalledOnly
-- >>> elem "base" . map fst . toList $ db
-- True
toList :: VerDB -> [(PkgName, Ver)]
toList :: VerDB -> [(String, Ver)]
toList (VerDB [(String, Ver)]
alist) = [(String, Ver)]
alist

-- | Converting 'VerDB' to 'Map'.
toMap :: VerDB -> Map PkgName Ver
toMap :: VerDB -> Map String Ver
toMap (VerDB [(String, Ver)]
alist) = [(String, Ver)] -> Map String Ver
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(String, Ver)]
alist

----------------------------------------------------------------

verinfos :: Parser [VerInfo]
verinfos :: Parser ByteString [(String, Maybe [Int])]
verinfos = Parser ByteString (String, Maybe [Int])
-> Parser ByteString [(String, Maybe [Int])]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many1 Parser ByteString (String, Maybe [Int])
verinfo

verinfo :: Parser VerInfo
verinfo :: Parser ByteString (String, Maybe [Int])
verinfo = do
    String
name <- ByteString -> Parser ByteString
string ByteString
"* " Parser ByteString
-> Parser ByteString String -> Parser ByteString String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString String
nonEols Parser ByteString String
-> Parser ByteString () -> Parser ByteString String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
endOfLine
    Parser ByteString ()
synpsis
    Maybe [Int]
lat <- Parser ByteString
latestLabel Parser ByteString
-> Parser ByteString (Maybe [Int])
-> Parser ByteString (Maybe [Int])
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString (Maybe [Int])
latest Parser ByteString (Maybe [Int])
-> Parser ByteString () -> Parser ByteString (Maybe [Int])
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
endOfLine
    [()]
_ <- Parser ByteString () -> Parser ByteString [()]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser ByteString ()
skip
    Parser ByteString ()
endOfLine
    (String, Maybe [Int]) -> Parser ByteString (String, Maybe [Int])
forall (m :: * -> *) a. Monad m => a -> m a
return (String
name, Maybe [Int]
lat)
  where
    latestLabel :: Parser ByteString
latestLabel = ByteString -> Parser ByteString
string ByteString
"    Default available version: " -- cabal 0.10
              Parser ByteString -> Parser ByteString -> Parser ByteString
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
string ByteString
"    Latest version available: "  -- cabal 0.8
    skip :: Parser ByteString ()
skip = Parser ByteString String -> Parser ByteString [String]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many1 Parser ByteString String
nonEols Parser ByteString [String]
-> Parser ByteString () -> Parser ByteString ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString ()
endOfLine
    synpsis :: Parser ByteString ()
synpsis = ByteString -> Parser ByteString
string ByteString
"    Synopsis:" Parser ByteString
-> Parser ByteString String -> Parser ByteString String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString String
nonEols Parser ByteString String
-> Parser ByteString () -> Parser ByteString ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString ()
endOfLine Parser ByteString ()
-> Parser ByteString () -> Parser ByteString ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString ()
more
          Parser ByteString ()
-> Parser ByteString () -> Parser ByteString ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> () -> Parser ByteString ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      where
        more :: Parser ByteString ()
more = () () -> Parser ByteString [()] -> Parser ByteString ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Parser ByteString () -> Parser ByteString [()]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (ByteString -> Parser ByteString
string ByteString
"     " Parser ByteString
-> Parser ByteString String -> Parser ByteString String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString String
nonEols Parser ByteString String
-> Parser ByteString () -> Parser ByteString ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString ()
endOfLine)
    latest :: Parser ByteString (Maybe [Int])
latest = Maybe [Int]
forall a. Maybe a
Nothing Maybe [Int]
-> Parser ByteString String -> Parser ByteString (Maybe [Int])
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Char -> Parser Char
char Char
'[' Parser Char -> Parser ByteString String -> Parser ByteString String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString String
nonEols)
         Parser ByteString (Maybe [Int])
-> Parser ByteString (Maybe [Int])
-> Parser ByteString (Maybe [Int])
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Int] -> Maybe [Int]
forall a. a -> Maybe a
Just ([Int] -> Maybe [Int])
-> Parser ByteString [Int] -> Parser ByteString (Maybe [Int])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString [Int]
dotted

dotted :: Parser [Int]
dotted :: Parser ByteString [Int]
dotted = Parser Int
forall a. Integral a => Parser a
decimal Parser Int -> Parser Char -> Parser ByteString [Int]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy` Char -> Parser Char
char Char
'.'

nonEols :: Parser String
nonEols :: Parser ByteString String
nonEols = Parser Char -> Parser ByteString String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many1 (Parser Char -> Parser ByteString String)
-> Parser Char -> Parser ByteString String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Parser Char
satisfy (String -> Char -> Bool
notInClass String
"\r\n")