{-# LANGUAGE NoImplicitPrelude  #-}
{-# LANGUAGE OverloadedStrings  #-}

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

import           Data.Attoparsec.Args ( EscapingMode (..), argsParser )
import           Data.Attoparsec.Text as P
import           Data.Conduit ( await, leftover, toConsumer, yield )
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 ( HasProcessContext )
import qualified RIO.Text as T
import           Stack.GhcPkg ( createDatabase )
import           Stack.Prelude
import           Stack.Types.CompilerPaths ( GhcPkgExe (..), HasCompiler (..) )
import           Stack.Types.DumpPackage ( DumpPackage (..) )
import           Stack.Types.GhcPkgId ( GhcPkgId, parseGhcPkgId )

-- | 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, HasTerm env)
  => GhcPkgExe
  -> [Path Abs Dir] -- ^ if empty, use global

  -> ConduitM Text Void (RIO env) a
  -> RIO env a
ghcPkgDump :: forall env a.
(HasProcessContext env, HasTerm env) =>
GhcPkgExe
-> [Path Abs Dir] -> ConduitM Text Void (RIO env) a -> RIO env a
ghcPkgDump GhcPkgExe
pkgexe = forall env a.
(HasProcessContext env, HasTerm 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 ::
     (HasCompiler env, HasProcessContext env, HasTerm env)
  => GhcPkgExe
  -> PackageName
  -> [Path Abs Dir] -- ^ if empty, use global

  -> ConduitM Text Void (RIO env) a
  -> RIO env a
ghcPkgDescribe :: forall env a.
(HasCompiler env, HasProcessContext env, HasTerm 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, HasTerm 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, HasTerm 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, HasTerm 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, HasTerm 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 a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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