{-# LANGUAGE NoImplicitPrelude  #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts   #-}
{-# LANGUAGE RankNTypes         #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE TupleSections      #-}

module Stack.PackageDump
  ( Line
  , eachSection
  , eachPair
  , DumpPackage (..)
  , conduitDumpPackage
  , ghcPkgDump
  , ghcPkgDescribe
  , sinkMatching
  , pruneDeps
  ) where

import           Data.Attoparsec.Args
import           Data.Attoparsec.Text as P
import           Data.Conduit
import qualified Data.Conduit.List as CL
import qualified Data.Conduit.Text as CT
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Distribution.Text as C
import           Path.Extra ( toFilePathNoTrailingSep )
import           RIO.Process hiding ( readProcess )
import qualified RIO.Text as T
import           Stack.GhcPkg
import           Stack.Prelude
import           Stack.Types.Config
                   ( HasCompiler (..), GhcPkgExe (..), DumpPackage (..) )
import           Stack.Types.GhcPkgId

-- | Type representing exceptions thrown by functions exported by the

-- "Stack.PackageDump" module.

data PackageDumpException
    = MissingSingleField Text (Map Text [Line])
    | Couldn'tParseField Text [Line]
    deriving (Int -> PackageDumpException -> ShowS
[PackageDumpException] -> ShowS
PackageDumpException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PackageDumpException] -> ShowS
$cshowList :: [PackageDumpException] -> ShowS
show :: PackageDumpException -> String
$cshow :: PackageDumpException -> String
showsPrec :: Int -> PackageDumpException -> ShowS
$cshowsPrec :: Int -> PackageDumpException -> ShowS
Show, Typeable)

instance Exception PackageDumpException where
    displayException :: PackageDumpException -> String
displayException (MissingSingleField Text
name Map Text [Text]
values) = [String] -> String
unlines forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ String
"Error: [S-4257]\n"
            , String
"Expected single value for field name "
            , forall a. Show a => a -> String
show Text
name
            , String
" when parsing ghc-pkg dump output:"
            ]
        forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (\(Text
k, [Text]
v) -> String
"    " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Text
k, [Text]
v)) (forall k a. Map k a -> [(k, a)]
Map.toList Map Text [Text]
values)
    displayException (Couldn'tParseField Text
name [Text]
ls) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Error: [S-2016]\n"
        , String
"Couldn't parse the field "
        , forall a. Show a => a -> String
show Text
name
        , String
" from lines: "
        , forall a. Show a => a -> String
show [Text]
ls
        , String
"."
        ]

-- | Call ghc-pkg dump with appropriate flags and stream to the given @Sink@, for a single database

ghcPkgDump
    :: (HasProcessContext env, HasLogFunc env)
    => GhcPkgExe
    -> [Path Abs Dir] -- ^ if empty, use global

    -> ConduitM Text Void (RIO env) a
    -> RIO env a
ghcPkgDump :: forall env a.
(HasProcessContext env, HasLogFunc env) =>
GhcPkgExe
-> [Path Abs Dir] -> ConduitM Text Void (RIO env) a -> RIO env a
ghcPkgDump GhcPkgExe
pkgexe = forall env a.
(HasProcessContext env, HasLogFunc env) =>
GhcPkgExe
-> [String]
-> [Path Abs Dir]
-> ConduitM Text Void (RIO env) a
-> RIO env a
ghcPkgCmdArgs GhcPkgExe
pkgexe [String
"dump"]

-- | Call ghc-pkg describe with appropriate flags and stream to the given @Sink@, for a single database

ghcPkgDescribe
    :: (HasProcessContext env, HasLogFunc env, HasCompiler env)
    => GhcPkgExe
    -> PackageName
    -> [Path Abs Dir] -- ^ if empty, use global

    -> ConduitM Text Void (RIO env) a
    -> RIO env a
ghcPkgDescribe :: forall env a.
(HasProcessContext env, HasLogFunc env, HasCompiler env) =>
GhcPkgExe
-> PackageName
-> [Path Abs Dir]
-> ConduitM Text Void (RIO env) a
-> RIO env a
ghcPkgDescribe GhcPkgExe
pkgexe PackageName
pkgName' = forall env a.
(HasProcessContext env, HasLogFunc env) =>
GhcPkgExe
-> [String]
-> [Path Abs Dir]
-> ConduitM Text Void (RIO env) a
-> RIO env a
ghcPkgCmdArgs GhcPkgExe
pkgexe [String
"describe", String
"--simple-output", PackageName -> String
packageNameString PackageName
pkgName']

-- | Call ghc-pkg and stream to the given @Sink@, for a single database

ghcPkgCmdArgs
    :: (HasProcessContext env, HasLogFunc env)
    => GhcPkgExe
    -> [String]
    -> [Path Abs Dir] -- ^ if empty, use global

    -> ConduitM Text Void (RIO env) a
    -> RIO env a
ghcPkgCmdArgs :: forall env a.
(HasProcessContext env, HasLogFunc env) =>
GhcPkgExe
-> [String]
-> [Path Abs Dir]
-> ConduitM Text Void (RIO env) a
-> RIO env a
ghcPkgCmdArgs pkgexe :: GhcPkgExe
pkgexe@(GhcPkgExe Path Abs File
pkgPath) [String]
cmd [Path Abs Dir]
mpkgDbs ConduitM Text Void (RIO env) a
sink = do
    case forall a. [a] -> [a]
reverse [Path Abs Dir]
mpkgDbs of
        (Path Abs Dir
pkgDb:[Path Abs Dir]
_) -> forall env.
(HasProcessContext env, HasLogFunc env) =>
GhcPkgExe -> Path Abs Dir -> RIO env ()
createDatabase GhcPkgExe
pkgexe Path Abs Dir
pkgDb -- TODO maybe use some retry logic instead?

        [Path Abs Dir]
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    -- https://github.com/haskell/process/issues/251

    forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e o env.
(HasProcessContext env, HasLogFunc env, HasCallStack) =>
String
-> [String]
-> ConduitM ByteString Void (RIO env) e
-> ConduitM ByteString Void (RIO env) o
-> RIO env (e, o)
sinkProcessStderrStdout (forall b t. Path b t -> String
toFilePath Path Abs File
pkgPath) [String]
args forall (m :: * -> *) i o. Monad m => ConduitT i o m ()
CL.sinkNull ConduitT ByteString Void (RIO env) a
sink'
  where
    args :: [String]
args = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ case [Path Abs Dir]
mpkgDbs of
              [] -> [String
"--global", String
"--no-user-package-db"]
              [Path Abs Dir]
_ -> [String
"--user", String
"--no-user-package-db"] forall a. [a] -> [a] -> [a]
++
                  forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Path Abs Dir
pkgDb -> [String
"--package-db", forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
pkgDb]) [Path Abs Dir]
mpkgDbs
        , [String]
cmd
        , [String
"--expand-pkgroot"]
        ]
    sink' :: ConduitT ByteString Void (RIO env) a
sink' = forall (m :: * -> *). MonadThrow m => ConduitT ByteString Text m ()
CT.decodeUtf8 forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitM Text Void (RIO env) a
sink

-- | Prune a list of possible packages down to those whose dependencies are met.

--

-- * id uniquely identifies an item

--

-- * There can be multiple items per name

pruneDeps
    :: (Ord name, Ord id)
    => (id -> name) -- ^ extract the name from an id

    -> (item -> id) -- ^ the id of an item

    -> (item -> [id]) -- ^ get the dependencies of an item

    -> (item -> item -> item) -- ^ choose the desired of two possible items

    -> [item] -- ^ input items

    -> Map name item
pruneDeps :: forall name id item.
(Ord name, Ord id) =>
(id -> name)
-> (item -> id)
-> (item -> [id])
-> (item -> item -> item)
-> [item]
-> Map name item
pruneDeps id -> name
getName item -> id
getId item -> [id]
getDepends item -> item -> item
chooseBest =
      forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (id -> name
getName forall b c a. (b -> c) -> (a -> b) -> a -> c
. item -> id
getId forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall a. a -> a
id)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set id -> Set name -> [item] -> [item] -> [item]
loop forall a. Set a
Set.empty forall a. Set a
Set.empty []
  where
    loop :: Set id -> Set name -> [item] -> [item] -> [item]
loop Set id
foundIds Set name
usedNames [item]
foundItems [item]
dps =
        case forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map item -> Either (name, item) (Maybe item)
depsMet [item]
dps of
            ([], [Maybe item]
_) -> [item]
foundItems
            ([(name, item)]
s', [Maybe item]
dps') ->
                let foundIds' :: Map name item
foundIds' = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith item -> item -> item
chooseBest [(name, item)]
s'
                    foundIds'' :: Set id
foundIds'' = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map item -> id
getId forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems Map name item
foundIds'
                    usedNames' :: Set name
usedNames' = forall k a. Map k a -> Set k
Map.keysSet Map name item
foundIds'
                    foundItems' :: [item]
foundItems' = forall k a. Map k a -> [a]
Map.elems Map name item
foundIds'
                 in Set id -> Set name -> [item] -> [item] -> [item]
loop
                        (forall a. Ord a => Set a -> Set a -> Set a
Set.union Set id
foundIds Set id
foundIds'')
                        (forall a. Ord a => Set a -> Set a -> Set a
Set.union Set name
usedNames Set name
usedNames')
                        ([item]
foundItems forall a. [a] -> [a] -> [a]
++ [item]
foundItems')
                        (forall a. [Maybe a] -> [a]
catMaybes [Maybe item]
dps')
      where
        depsMet :: item -> Either (name, item) (Maybe item)
depsMet item
dp
            | name
name forall a. Ord a => a -> Set a -> Bool
`Set.member` Set name
usedNames = forall a b. b -> Either a b
Right forall a. Maybe a
Nothing
            | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Ord a => a -> Set a -> Bool
`Set.member` Set id
foundIds) (item -> [id]
getDepends item
dp) = forall a b. a -> Either a b
Left (name
name, item
dp)
            | Bool
otherwise = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just item
dp
          where
            id' :: id
id' = item -> id
getId item
dp
            name :: name
name = id -> name
getName id
id'

-- | Find the package IDs matching the given constraints with all dependencies installed.

-- Packages not mentioned in the provided @Map@ are allowed to be present too.

sinkMatching :: Monad m
             => Map PackageName Version -- ^ allowed versions

             -> ConduitM DumpPackage o m (Map PackageName DumpPackage)
sinkMatching :: forall (m :: * -> *) o.
Monad m =>
Map PackageName Version
-> ConduitM DumpPackage o m (Map PackageName DumpPackage)
sinkMatching Map PackageName Version
allowed =
      forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (PackageIdentifier -> PackageName
pkgName forall b c a. (b -> c) -> (a -> b) -> a -> c
. DumpPackage -> PackageIdentifier
dpPackageIdent forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall a. a -> a
id)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [a]
Map.elems
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall name id item.
(Ord name, Ord id) =>
(id -> name)
-> (item -> id)
-> (item -> [id])
-> (item -> item -> item)
-> [item]
-> Map name item
pruneDeps
        forall a. a -> a
id
        DumpPackage -> GhcPkgId
dpGhcPkgId
        DumpPackage -> [GhcPkgId]
dpDepends
        forall a b. a -> b -> a
const -- Could consider a better comparison in the future

    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (m :: * -> *) a. Monad m => (a -> Bool) -> ConduitT a a m ()
CL.filter (PackageIdentifier -> Bool
isAllowed forall b c a. (b -> c) -> (a -> b) -> a -> c
. DumpPackage -> PackageIdentifier
dpPackageIdent) forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
CL.consume)
  where
    isAllowed :: PackageIdentifier -> Bool
isAllowed (PackageIdentifier PackageName
name Version
version) =
        case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name Map PackageName Version
allowed of
            Just Version
version' | Version
version forall a. Eq a => a -> a -> Bool
/= Version
version' -> Bool
False
            Maybe Version
_ -> Bool
True

-- | Convert a stream of bytes into a stream of @DumpPackage@s

conduitDumpPackage :: MonadThrow m
                   => ConduitM Text DumpPackage m ()
conduitDumpPackage :: forall (m :: * -> *).
MonadThrow m =>
ConduitM Text DumpPackage m ()
conduitDumpPackage = (forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a. Monad m => ConduitT (Maybe a) a m ()
CL.catMaybes) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
ConduitM Text Void m a -> ConduitM Text a m ()
eachSection forall a b. (a -> b) -> a -> b
$ do
    [(Text, [Text])]
pairs <- forall (m :: * -> *) a.
Monad m =>
(Text -> ConduitM Text Void m a) -> ConduitM Text a m ()
eachPair (\Text
k -> (Text
k, ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
CL.consume) forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
CL.consume
    let m :: Map Text [Text]
m = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text, [Text])]
pairs
    let parseS :: Text -> f Text
parseS Text
k =
            case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
k Map Text [Text]
m of
                Just [Text
v] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
v
                Maybe [Text]
_ -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Text -> Map Text [Text] -> PackageDumpException
MissingSingleField Text
k Map Text [Text]
m
        -- Can't fail: if not found, same as an empty list. See:

        -- https://github.com/commercialhaskell/stack/issues/182

        parseM :: Text -> [Text]
parseM Text
k = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] Text
k Map Text [Text]
m

        parseDepend :: MonadThrow m => Text -> m (Maybe GhcPkgId)
        parseDepend :: forall (m :: * -> *). MonadThrow m => Text -> m (Maybe GhcPkgId)
parseDepend Text
"builtin_rts" = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        parseDepend Text
bs =
            forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadThrow m => Text -> m GhcPkgId
parseGhcPkgId Text
bs'
          where
            (Text
bs', Bool
_builtinRts) =
                case Text -> Text -> Maybe Text
stripSuffixText Text
" builtin_rts" Text
bs of
                    Maybe Text
Nothing ->
                        case Text -> Text -> Maybe Text
stripPrefixText Text
"builtin_rts " Text
bs of
                            Maybe Text
Nothing -> (Text
bs, Bool
False)
                            Just Text
x -> (Text
x, Bool
True)
                    Just Text
x -> (Text
x, Bool
True)
    case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
"id" Map Text [Text]
m of
        Just [Text
"builtin_rts"] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        Maybe [Text]
_ -> do
            PackageName
name <- forall {f :: * -> *}. MonadThrow f => Text -> f Text
parseS Text
"name" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadThrow m => String -> m PackageName
parsePackageNameThrowing forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
            Version
version <- forall {f :: * -> *}. MonadThrow f => Text -> f Text
parseS Text
"version" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadThrow m => String -> m Version
parseVersionThrowing forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
            GhcPkgId
ghcPkgId <- forall {f :: * -> *}. MonadThrow f => Text -> f Text
parseS Text
"id" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadThrow m => Text -> m GhcPkgId
parseGhcPkgId

            -- if a package has no modules, these won't exist

            let libDirKey :: Text
libDirKey = Text
"library-dirs"
                libraries :: [Text]
libraries = Text -> [Text]
parseM Text
"hs-libraries"
                exposedModules :: [Text]
exposedModules = Text -> [Text]
parseM Text
"exposed-modules"
                exposed :: [Text]
exposed = Text -> [Text]
parseM Text
"exposed"
                license :: Maybe License
license =
                    case Text -> [Text]
parseM Text
"license" of
                        [Text
licenseText] -> forall a. Parsec a => String -> Maybe a
C.simpleParse (Text -> String
T.unpack Text
licenseText)
                        [Text]
_ -> forall a. Maybe a
Nothing
            [GhcPkgId]
depends <- forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM forall (m :: * -> *). MonadThrow m => Text -> m (Maybe GhcPkgId)
parseDepend forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Text -> [Text]
T.words forall a b. (a -> b) -> a -> b
$ Text -> [Text]
parseM Text
"depends"

            -- Handle sublibs by recording the name of the parent library

            -- If name of parent library is missing, this is not a sublib.

            let mkParentLib :: PackageName -> PackageIdentifier
mkParentLib PackageName
n = PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
n Version
version
                parentLib :: Maybe PackageIdentifier
parentLib = PackageName -> PackageIdentifier
mkParentLib forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall {f :: * -> *}. MonadThrow f => Text -> f Text
parseS Text
"package-name" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                                             forall (m :: * -> *). MonadThrow m => String -> m PackageName
parsePackageNameThrowing forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack)

            let parseQuoted :: Text -> m [String]
parseQuoted Text
key =
                    case forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a. Parser a -> Text -> Either String a
P.parseOnly (EscapingMode -> Parser [String]
argsParser EscapingMode
NoEscaping)) [Text]
val of
                        Left{} -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (Text -> [Text] -> PackageDumpException
Couldn'tParseField Text
key [Text]
val)
                        Right [[String]]
dirs -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[String]]
dirs)
                  where
                    val :: [Text]
val = Text -> [Text]
parseM Text
key
            [String]
libDirPaths <- forall {m :: * -> *}. MonadThrow m => Text -> m [String]
parseQuoted Text
libDirKey
            [String]
haddockInterfaces <- forall {m :: * -> *}. MonadThrow m => Text -> m [String]
parseQuoted Text
"haddock-interfaces"
            [String]
haddockHtml <- forall {m :: * -> *}. MonadThrow m => Text -> m [String]
parseQuoted Text
"haddock-html"

            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just DumpPackage
                { dpGhcPkgId :: GhcPkgId
dpGhcPkgId = GhcPkgId
ghcPkgId
                , dpPackageIdent :: PackageIdentifier
dpPackageIdent = PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
version
                , dpParentLibIdent :: Maybe PackageIdentifier
dpParentLibIdent = Maybe PackageIdentifier
parentLib
                , dpLicense :: Maybe License
dpLicense = Maybe License
license
                , dpLibDirs :: [String]
dpLibDirs = [String]
libDirPaths
                , dpLibraries :: [Text]
dpLibraries = Text -> [Text]
T.words forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unwords [Text]
libraries
                , dpHasExposedModules :: Bool
dpHasExposedModules = Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
libraries Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
exposedModules)

                -- Strip trailing commas from ghc package exposed-modules (looks buggy to me...).

                -- Then try to parse the module names.

                , dpExposedModules :: Set ModuleName
dpExposedModules =
                      forall a. Ord a => [a] -> Set a
Set.fromList
                    forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall a. Parsec a => String -> Maybe a
C.simpleParse forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text
T.dropSuffix Text
",")
                    forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.words
                    forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unwords [Text]
exposedModules

                , dpDepends :: [GhcPkgId]
dpDepends = [GhcPkgId]
depends
                , dpHaddockInterfaces :: [String]
dpHaddockInterfaces = [String]
haddockInterfaces
                , dpHaddockHtml :: Maybe String
dpHaddockHtml = forall a. [a] -> Maybe a
listToMaybe [String]
haddockHtml
                , dpIsExposed :: Bool
dpIsExposed = [Text]
exposed forall a. Eq a => a -> a -> Bool
== [Text
"True"]
                }

stripPrefixText :: Text -> Text -> Maybe Text
stripPrefixText :: Text -> Text -> Maybe Text
stripPrefixText Text
x Text
y
    | Text
x Text -> Text -> Bool
`T.isPrefixOf` Text
y = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.drop (Text -> Int
T.length Text
x) Text
y
    | Bool
otherwise = forall a. Maybe a
Nothing

stripSuffixText :: Text -> Text -> Maybe Text
stripSuffixText :: Text -> Text -> Maybe Text
stripSuffixText Text
x Text
y
    | Text
x Text -> Text -> Bool
`T.isSuffixOf` Text
y = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.take (Text -> Int
T.length Text
y forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
x) Text
y
    | Bool
otherwise = forall a. Maybe a
Nothing

-- | A single line of input, not including line endings

type Line = Text

-- | Apply the given Sink to each section of output, broken by a single line containing ---

eachSection :: Monad m
            => ConduitM Line Void m a
            -> ConduitM Text a m ()
eachSection :: forall (m :: * -> *) a.
Monad m =>
ConduitM Text Void m a -> ConduitM Text a m ()
eachSection ConduitM Text Void m a
inner =
    forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
CL.map ((Char -> Bool) -> Text -> Text
T.filter (forall a. Eq a => a -> a -> Bool
/= Char
'\r')) forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *). Monad m => ConduitT Text Text m ()
CT.lines forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT Text a m ()
start
  where

    peekText :: ConduitT Text o m (Maybe Text)
peekText = forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing) (\Text
bs ->
        if Text -> Bool
T.null Text
bs
            then ConduitT Text o m (Maybe Text)
peekText
            else forall i o (m :: * -> *). i -> ConduitT i o m ()
leftover Text
bs forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just Text
bs))

    start :: ConduitT Text a m ()
start = forall {o}. ConduitT Text o m (Maybe Text)
peekText forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (forall a b. a -> b -> a
const ConduitT Text a m ()
go)

    go :: ConduitT Text a m ()
go = do
        a
x <- forall (m :: * -> *) a b o.
Monad m =>
ConduitT a Void m b -> ConduitT a o m b
toConsumer forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => (a -> Bool) -> ConduitT a a m ()
takeWhileC (forall a. Eq a => a -> a -> Bool
/= Text
"---") forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitM Text Void m a
inner
        forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield a
x
        forall (m :: * -> *) a o. Monad m => Int -> ConduitT a o m ()
CL.drop Int
1
        ConduitT Text a m ()
start

-- | Grab each key/value pair

eachPair :: Monad m
         => (Text -> ConduitM Line Void m a)
         -> ConduitM Line a m ()
eachPair :: forall (m :: * -> *) a.
Monad m =>
(Text -> ConduitM Text Void m a) -> ConduitM Text a m ()
eachPair Text -> ConduitM Text Void m a
inner =
    ConduitT Text a m ()
start
  where
    start :: ConduitT Text a m ()
start = forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) Text -> ConduitT Text a m ()
start'

    start' :: Text -> ConduitT Text a m ()
start' Text
bs1 =
        forall (m :: * -> *) a b o.
Monad m =>
ConduitT a Void m b -> ConduitT a o m b
toConsumer (ConduitT Text Text m ()
valSrc forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| Text -> ConduitM Text Void m a
inner Text
key) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ConduitT Text a m ()
start
      where
        (Text
key, Text
bs2) = (Char -> Bool) -> Text -> (Text, Text)
T.break (forall a. Eq a => a -> a -> Bool
== Char
':') Text
bs1
        (Text
spaces, Text
bs3) = (Char -> Bool) -> Text -> (Text, Text)
T.span (forall a. Eq a => a -> a -> Bool
== Char
' ') forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.drop Int
1 Text
bs2
        ind :: Int
ind = Text -> Int
T.length Text
key forall a. Num a => a -> a -> a
+ Int
1 forall a. Num a => a -> a -> a
+ Text -> Int
T.length Text
spaces

        valSrc :: ConduitT Text Text m ()
valSrc
            | Text -> Bool
T.null Text
bs3 = ConduitT Text Text m ()
noIndent
            | Bool
otherwise = forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield Text
bs3 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall {m :: * -> *}. Monad m => Int -> ConduitT Text Text m ()
loopIndent Int
ind

    noIndent :: ConduitT Text Text m ()
noIndent = do
        Maybe Text
mx <- forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await
        case Maybe Text
mx of
            Maybe Text
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Just Text
bs -> do
                let (Text
spaces, Text
val) = (Char -> Bool) -> Text -> (Text, Text)
T.span (forall a. Eq a => a -> a -> Bool
== Char
' ') Text
bs
                if Text -> Int
T.length Text
spaces forall a. Eq a => a -> a -> Bool
== Int
0
                    then forall i o (m :: * -> *). i -> ConduitT i o m ()
leftover Text
val
                    else do
                        forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield Text
val
                        forall {m :: * -> *}. Monad m => Int -> ConduitT Text Text m ()
loopIndent (Text -> Int
T.length Text
spaces)

    loopIndent :: Int -> ConduitT Text Text m ()
loopIndent Int
i =
        ConduitT Text Text m ()
loop
      where
        loop :: ConduitT Text Text m ()
loop = forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) Text -> ConduitT Text Text m ()
go

        go :: Text -> ConduitT Text Text m ()
go Text
bs
            | Text -> Int
T.length Text
spaces forall a. Eq a => a -> a -> Bool
== Int
i Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
T.all (forall a. Eq a => a -> a -> Bool
== Char
' ') Text
spaces =
                forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield Text
val forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ConduitT Text Text m ()
loop
            | Bool
otherwise = forall i o (m :: * -> *). i -> ConduitT i o m ()
leftover Text
bs
          where
            (Text
spaces, Text
val) = Int -> Text -> (Text, Text)
T.splitAt Int
i Text
bs

-- | General purpose utility

takeWhileC :: Monad m => (a -> Bool) -> ConduitM a a m ()
takeWhileC :: forall (m :: * -> *) a. Monad m => (a -> Bool) -> ConduitT a a m ()
takeWhileC a -> Bool
f =
    ConduitT a a m ()
loop
  where
    loop :: ConduitT a a m ()
loop = forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) a -> ConduitT a a m ()
go

    go :: a -> ConduitT a a m ()
go a
x
        | a -> Bool
f a
x = forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield a
x forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ConduitT a a m ()
loop
        | Bool
otherwise = forall i o (m :: * -> *). i -> ConduitT i o m ()
leftover a
x