{-# 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
(Int -> PackageDumpException -> ShowS)
-> (PackageDumpException -> String)
-> ([PackageDumpException] -> ShowS)
-> Show PackageDumpException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PackageDumpException -> ShowS
showsPrec :: Int -> PackageDumpException -> ShowS
$cshow :: PackageDumpException -> String
show :: PackageDumpException -> String
$cshowList :: [PackageDumpException] -> ShowS
showList :: [PackageDumpException] -> ShowS
Show, Typeable)

instance Exception PackageDumpException where
  displayException :: PackageDumpException -> String
displayException (MissingSingleField Text
name Map Text [Text]
values) = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
    [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ String
"Error: [S-4257]\n"
      , String
"Expected single value for field name "
      , Text -> String
forall a. Show a => a -> String
show Text
name
      , String
" when parsing ghc-pkg dump output:"
      ]
    String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ((Text, [Text]) -> String) -> [(Text, [Text])] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(Text
k, [Text]
v) -> String
"    " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Text, [Text]) -> String
forall a. Show a => a -> String
show (Text
k, [Text]
v)) (Map Text [Text] -> [(Text, [Text])]
forall k a. Map k a -> [(k, a)]
Map.toList Map Text [Text]
values)
  displayException (Couldn'tParseField Text
name [Text]
ls) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ String
"Error: [S-2016]\n"
    , String
"Couldn't parse the field "
    , Text -> String
forall a. Show a => a -> String
show Text
name
    , String
" from lines: "
    , [Text] -> String
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 = GhcPkgExe
-> [String]
-> [Path Abs Dir]
-> ConduitM Text Void (RIO env) a
-> RIO env a
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' = GhcPkgExe
-> [String]
-> [Path Abs Dir]
-> ConduitM Text Void (RIO env) a
-> RIO env a
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 [Path Abs Dir] -> [Path Abs Dir]
forall a. [a] -> [a]
reverse [Path Abs Dir]
mpkgDbs of
      (Path Abs Dir
pkgDb:[Path Abs Dir]
_) -> GhcPkgExe -> Path Abs Dir -> RIO env ()
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]
_ -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  -- https://github.com/haskell/process/issues/251

  ((), a) -> a
forall a b. (a, b) -> b
snd (((), a) -> a) -> RIO env ((), a) -> RIO env a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> [String]
-> ConduitM ByteString Void (RIO env) ()
-> ConduitM ByteString Void (RIO env) a
-> RIO env ((), a)
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 (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
pkgPath) [String]
args ConduitM ByteString Void (RIO env) ()
forall (m :: * -> *) i o. Monad m => ConduitT i o m ()
CL.sinkNull ConduitM ByteString Void (RIO env) a
sink'
 where
  args :: [String]
args = [[String]] -> [String]
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"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
              (Path Abs Dir -> [String]) -> [Path Abs Dir] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Path Abs Dir
pkgDb -> [String
"--package-db", Path Abs Dir -> String
forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
pkgDb]) [Path Abs Dir]
mpkgDbs
    , [String]
cmd
    , [String
"--expand-pkgroot"]
    ]
  sink' :: ConduitM ByteString Void (RIO env) a
sink' = ConduitT ByteString Text (RIO env) ()
forall (m :: * -> *). MonadThrow m => ConduitT ByteString Text m ()
CT.decodeUtf8 ConduitT ByteString Text (RIO env) ()
-> ConduitM Text Void (RIO env) a
-> ConduitM ByteString Void (RIO env) a
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 =
    [(name, item)] -> Map name item
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
  ([(name, item)] -> Map name item)
-> ([item] -> [(name, item)]) -> [item] -> Map name item
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (item -> (name, item)) -> [item] -> [(name, item)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (id -> name
getName (id -> name) -> (item -> id) -> item -> name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. item -> id
getId (item -> name) -> (item -> item) -> item -> (name, item)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& item -> item
forall a. a -> a
id)
  ([item] -> [(name, item)])
-> ([item] -> [item]) -> [item] -> [(name, item)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set id -> Set name -> [item] -> [item] -> [item]
loop Set id
forall a. Set a
Set.empty Set name
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 [Either (name, item) (Maybe item)]
-> ([(name, item)], [Maybe item])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either (name, item) (Maybe item)]
 -> ([(name, item)], [Maybe item]))
-> [Either (name, item) (Maybe item)]
-> ([(name, item)], [Maybe item])
forall a b. (a -> b) -> a -> b
$ (item -> Either (name, item) (Maybe item))
-> [item] -> [Either (name, item) (Maybe item)]
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' = (item -> item -> item) -> [(name, item)] -> Map name item
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'' = [id] -> Set id
forall a. Ord a => [a] -> Set a
Set.fromList ([id] -> Set id) -> [id] -> Set id
forall a b. (a -> b) -> a -> b
$ (item -> id) -> [item] -> [id]
forall a b. (a -> b) -> [a] -> [b]
map item -> id
getId ([item] -> [id]) -> [item] -> [id]
forall a b. (a -> b) -> a -> b
$ Map name item -> [item]
forall k a. Map k a -> [a]
Map.elems Map name item
foundIds'
            usedNames' :: Set name
usedNames' = Map name item -> Set name
forall k a. Map k a -> Set k
Map.keysSet Map name item
foundIds'
            foundItems' :: [item]
foundItems' = Map name item -> [item]
forall k a. Map k a -> [a]
Map.elems Map name item
foundIds'
        in  Set id -> Set name -> [item] -> [item] -> [item]
loop
              (Set id -> Set id -> Set id
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set id
foundIds Set id
foundIds'')
              (Set name -> Set name -> Set name
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set name
usedNames Set name
usedNames')
              ([item]
foundItems [item] -> [item] -> [item]
forall a. [a] -> [a] -> [a]
++ [item]
foundItems')
              ([Maybe item] -> [item]
forall a. [Maybe a] -> [a]
catMaybes [Maybe item]
dps')
   where
    depsMet :: item -> Either (name, item) (Maybe item)
depsMet item
dp
      | name
name name -> Set name -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set name
usedNames = Maybe item -> Either (name, item) (Maybe item)
forall a b. b -> Either a b
Right Maybe item
forall a. Maybe a
Nothing
      | (id -> Bool) -> [id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (id -> Set id -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set id
foundIds) (item -> [id]
getDepends item
dp) = (name, item) -> Either (name, item) (Maybe item)
forall a b. a -> Either a b
Left (name
name, item
dp)
      | Bool
otherwise = Maybe item -> Either (name, item) (Maybe item)
forall a b. b -> Either a b
Right (Maybe item -> Either (name, item) (Maybe item))
-> Maybe item -> Either (name, item) (Maybe item)
forall a b. (a -> b) -> a -> b
$ item -> Maybe item
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 =
    [(PackageName, DumpPackage)] -> Map PackageName DumpPackage
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
  ([(PackageName, DumpPackage)] -> Map PackageName DumpPackage)
-> ([DumpPackage] -> [(PackageName, DumpPackage)])
-> [DumpPackage]
-> Map PackageName DumpPackage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DumpPackage -> (PackageName, DumpPackage))
-> [DumpPackage] -> [(PackageName, DumpPackage)]
forall a b. (a -> b) -> [a] -> [b]
map (PackageIdentifier -> PackageName
pkgName (PackageIdentifier -> PackageName)
-> (DumpPackage -> PackageIdentifier) -> DumpPackage -> PackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DumpPackage -> PackageIdentifier
dpPackageIdent (DumpPackage -> PackageName)
-> (DumpPackage -> DumpPackage)
-> DumpPackage
-> (PackageName, DumpPackage)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& DumpPackage -> DumpPackage
forall a. a -> a
id)
  ([DumpPackage] -> [(PackageName, DumpPackage)])
-> ([DumpPackage] -> [DumpPackage])
-> [DumpPackage]
-> [(PackageName, DumpPackage)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map GhcPkgId DumpPackage -> [DumpPackage]
forall k a. Map k a -> [a]
Map.elems
  (Map GhcPkgId DumpPackage -> [DumpPackage])
-> ([DumpPackage] -> Map GhcPkgId DumpPackage)
-> [DumpPackage]
-> [DumpPackage]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GhcPkgId -> GhcPkgId)
-> (DumpPackage -> GhcPkgId)
-> (DumpPackage -> [GhcPkgId])
-> (DumpPackage -> DumpPackage -> DumpPackage)
-> [DumpPackage]
-> Map GhcPkgId DumpPackage
forall name id item.
(Ord name, Ord id) =>
(id -> name)
-> (item -> id)
-> (item -> [id])
-> (item -> item -> item)
-> [item]
-> Map name item
pruneDeps
      GhcPkgId -> GhcPkgId
forall a. a -> a
id
      DumpPackage -> GhcPkgId
dpGhcPkgId
      DumpPackage -> [GhcPkgId]
dpDepends
      DumpPackage -> DumpPackage -> DumpPackage
forall a b. a -> b -> a
const -- Could consider a better comparison in the future

  ([DumpPackage] -> Map PackageName DumpPackage)
-> ConduitT DumpPackage o m [DumpPackage]
-> ConduitT DumpPackage o m (Map PackageName DumpPackage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((DumpPackage -> Bool) -> ConduitT DumpPackage DumpPackage m ()
forall (m :: * -> *) a. Monad m => (a -> Bool) -> ConduitT a a m ()
CL.filter (PackageIdentifier -> Bool
isAllowed (PackageIdentifier -> Bool)
-> (DumpPackage -> PackageIdentifier) -> DumpPackage -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DumpPackage -> PackageIdentifier
dpPackageIdent) ConduitT DumpPackage DumpPackage m ()
-> ConduitT DumpPackage o m [DumpPackage]
-> ConduitT DumpPackage o m [DumpPackage]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT DumpPackage o m [DumpPackage]
forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
CL.consume)
 where
  isAllowed :: PackageIdentifier -> Bool
isAllowed (PackageIdentifier PackageName
name Version
version) =
    case PackageName -> Map PackageName Version -> Maybe Version
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 Version -> Version -> Bool
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 = (ConduitT Text (Maybe DumpPackage) m ()
-> ConduitT (Maybe DumpPackage) DumpPackage m ()
-> ConduitT Text DumpPackage m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT (Maybe DumpPackage) DumpPackage m ()
forall (m :: * -> *) a. Monad m => ConduitT (Maybe a) a m ()
CL.catMaybes) (ConduitT Text (Maybe DumpPackage) m ()
 -> ConduitT Text DumpPackage m ())
-> ConduitT Text (Maybe DumpPackage) m ()
-> ConduitT Text DumpPackage m ()
forall a b. (a -> b) -> a -> b
$ ConduitM Text Void m (Maybe DumpPackage)
-> ConduitT Text (Maybe DumpPackage) m ()
forall (m :: * -> *) a.
Monad m =>
ConduitM Text Void m a -> ConduitM Text a m ()
eachSection (ConduitM Text Void m (Maybe DumpPackage)
 -> ConduitT Text (Maybe DumpPackage) m ())
-> ConduitM Text Void m (Maybe DumpPackage)
-> ConduitT Text (Maybe DumpPackage) m ()
forall a b. (a -> b) -> a -> b
$ do
  [(Text, [Text])]
pairs <- (Text -> ConduitM Text Void m (Text, [Text]))
-> ConduitM Text (Text, [Text]) m ()
forall (m :: * -> *) a.
Monad m =>
(Text -> ConduitM Text Void m a) -> ConduitM Text a m ()
eachPair (\Text
k -> (Text
k, ) ([Text] -> (Text, [Text]))
-> ConduitT Text Void m [Text]
-> ConduitM Text Void m (Text, [Text])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConduitT Text Void m [Text]
forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
CL.consume) ConduitM Text (Text, [Text]) m ()
-> ConduitT (Text, [Text]) Void m [(Text, [Text])]
-> ConduitT Text Void m [(Text, [Text])]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT (Text, [Text]) Void m [(Text, [Text])]
forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
CL.consume
  let m :: Map Text [Text]
m = [(Text, [Text])] -> Map Text [Text]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text, [Text])]
pairs
  let parseS :: Text -> f Text
parseS Text
k =
        case Text -> Map Text [Text] -> Maybe [Text]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
k Map Text [Text]
m of
          Just [Text
v] -> Text -> f Text
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
v
          Maybe [Text]
_ -> PackageDumpException -> f Text
forall e a. Exception e => e -> f a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (PackageDumpException -> f Text) -> PackageDumpException -> f Text
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 = [Text] -> Text -> Map Text [Text] -> [Text]
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" = Maybe GhcPkgId -> m (Maybe GhcPkgId)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe GhcPkgId
forall a. Maybe a
Nothing
      parseDepend Text
bs = GhcPkgId -> Maybe GhcPkgId
forall a. a -> Maybe a
Just (GhcPkgId -> Maybe GhcPkgId) -> m GhcPkgId -> m (Maybe GhcPkgId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> m GhcPkgId
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 Text -> Map Text [Text] -> Maybe [Text]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
"id" Map Text [Text]
m of
    Just [Text
"builtin_rts"] -> Maybe DumpPackage -> ConduitM Text Void m (Maybe DumpPackage)
forall a. a -> ConduitT Text Void m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe DumpPackage
forall a. Maybe a
Nothing
    Maybe [Text]
_ -> do
      PackageName
name <- Text -> ConduitT Text Void m Text
forall {f :: * -> *}. MonadThrow f => Text -> f Text
parseS Text
"name" ConduitT Text Void m Text
-> (Text -> ConduitT Text Void m PackageName)
-> ConduitT Text Void m PackageName
forall a b.
ConduitT Text Void m a
-> (a -> ConduitT Text Void m b) -> ConduitT Text Void m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> ConduitT Text Void m PackageName
forall (m :: * -> *). MonadThrow m => String -> m PackageName
parsePackageNameThrowing (String -> ConduitT Text Void m PackageName)
-> (Text -> String) -> Text -> ConduitT Text Void m PackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
      Version
version <- Text -> ConduitT Text Void m Text
forall {f :: * -> *}. MonadThrow f => Text -> f Text
parseS Text
"version" ConduitT Text Void m Text
-> (Text -> ConduitT Text Void m Version)
-> ConduitT Text Void m Version
forall a b.
ConduitT Text Void m a
-> (a -> ConduitT Text Void m b) -> ConduitT Text Void m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> ConduitT Text Void m Version
forall (m :: * -> *). MonadThrow m => String -> m Version
parseVersionThrowing (String -> ConduitT Text Void m Version)
-> (Text -> String) -> Text -> ConduitT Text Void m Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
      GhcPkgId
ghcPkgId <- Text -> ConduitT Text Void m Text
forall {f :: * -> *}. MonadThrow f => Text -> f Text
parseS Text
"id" ConduitT Text Void m Text
-> (Text -> ConduitT Text Void m GhcPkgId)
-> ConduitT Text Void m GhcPkgId
forall a b.
ConduitT Text Void m a
-> (a -> ConduitT Text Void m b) -> ConduitT Text Void m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> ConduitT Text Void m GhcPkgId
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] -> String -> Maybe License
forall a. Parsec a => String -> Maybe a
C.simpleParse (Text -> String
T.unpack Text
licenseText)
              [Text]
_ -> Maybe License
forall a. Maybe a
Nothing
      [GhcPkgId]
depends <- (Text -> ConduitT Text Void m (Maybe GhcPkgId))
-> [Text] -> ConduitT Text Void m [GhcPkgId]
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM Text -> ConduitT Text Void m (Maybe GhcPkgId)
forall (m :: * -> *). MonadThrow m => Text -> m (Maybe GhcPkgId)
parseDepend ([Text] -> ConduitT Text Void m [GhcPkgId])
-> [Text] -> ConduitT Text Void m [GhcPkgId]
forall a b. (a -> b) -> a -> b
$ (Text -> [Text]) -> [Text] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Text -> [Text]
T.words ([Text] -> [Text]) -> [Text] -> [Text]
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 (PackageName -> PackageIdentifier)
-> Maybe PackageName -> Maybe PackageIdentifier
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Maybe Text
forall {f :: * -> *}. MonadThrow f => Text -> f Text
parseS Text
"package-name" Maybe Text -> (Text -> Maybe PackageName) -> Maybe PackageName
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                                       String -> Maybe PackageName
forall (m :: * -> *). MonadThrow m => String -> m PackageName
parsePackageNameThrowing (String -> Maybe PackageName)
-> (Text -> String) -> Text -> Maybe PackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack)

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

      Maybe DumpPackage -> ConduitM Text Void m (Maybe DumpPackage)
forall a. a -> ConduitT Text Void m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe DumpPackage -> ConduitM Text Void m (Maybe DumpPackage))
-> Maybe DumpPackage -> ConduitM Text Void m (Maybe DumpPackage)
forall a b. (a -> b) -> a -> b
$ DumpPackage -> Maybe DumpPackage
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 (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unwords [Text]
libraries
        , dpHasExposedModules :: Bool
dpHasExposedModules = Bool -> Bool
not ([Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
libraries Bool -> Bool -> Bool
|| [Text] -> Bool
forall a. [a] -> 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 =
              [ModuleName] -> Set ModuleName
forall a. Ord a => [a] -> Set a
Set.fromList
            ([ModuleName] -> Set ModuleName) -> [ModuleName] -> Set ModuleName
forall a b. (a -> b) -> a -> b
$ (Text -> Maybe ModuleName) -> [Text] -> [ModuleName]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (String -> Maybe ModuleName
forall a. Parsec a => String -> Maybe a
C.simpleParse (String -> Maybe ModuleName)
-> (Text -> String) -> Text -> Maybe ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String) -> (Text -> Text) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text
T.dropSuffix Text
",")
            ([Text] -> [ModuleName]) -> [Text] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.words
            (Text -> [Text]) -> Text -> [Text]
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 = [String] -> Maybe String
forall a. [a] -> Maybe a
listToMaybe [String]
haddockHtml
        , dpIsExposed :: Bool
dpIsExposed = [Text]
exposed [Text] -> [Text] -> Bool
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 = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.drop (Text -> Int
T.length Text
x) Text
y
  | Bool
otherwise = Maybe Text
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 = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.take (Text -> Int
T.length Text
y Int -> Int -> Int
forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
x) Text
y
  | Bool
otherwise = Maybe Text
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 = (Text -> Text) -> ConduitT Text Text m ()
forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
CL.map ((Char -> Bool) -> Text -> Text
T.filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\r')) ConduitT Text Text m ()
-> ConduitT Text a m () -> ConduitT Text a m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT Text Text m ()
forall (m :: * -> *). Monad m => ConduitT Text Text m ()
CT.lines ConduitT Text Text m ()
-> ConduitT Text a m () -> ConduitT Text a m ()
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 = ConduitT Text o m (Maybe Text)
forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await ConduitT Text o m (Maybe Text)
-> (Maybe Text -> ConduitT Text o m (Maybe Text))
-> ConduitT Text o m (Maybe Text)
forall a b.
ConduitT Text o m a
-> (a -> ConduitT Text o m b) -> ConduitT Text o m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ConduitT Text o m (Maybe Text)
-> (Text -> ConduitT Text o m (Maybe Text))
-> Maybe Text
-> ConduitT Text o m (Maybe Text)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe Text -> ConduitT Text o m (Maybe Text)
forall a. a -> ConduitT Text o m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing) (\Text
bs ->
    if Text -> Bool
T.null Text
bs
      then ConduitT Text o m (Maybe Text)
peekText
      else Text -> ConduitT Text o m ()
forall i o (m :: * -> *). i -> ConduitT i o m ()
leftover Text
bs ConduitT Text o m ()
-> ConduitT Text o m (Maybe Text) -> ConduitT Text o m (Maybe Text)
forall a b.
ConduitT Text o m a -> ConduitT Text o m b -> ConduitT Text o m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe Text -> ConduitT Text o m (Maybe Text)
forall a. a -> ConduitT Text o m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
bs))

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

  go :: ConduitT Text a m ()
go = do
    a
x <- ConduitM Text Void m a -> ConduitT Text a m a
forall (m :: * -> *) a b o.
Monad m =>
ConduitT a Void m b -> ConduitT a o m b
toConsumer (ConduitM Text Void m a -> ConduitT Text a m a)
-> ConduitM Text Void m a -> ConduitT Text a m a
forall a b. (a -> b) -> a -> b
$ (Text -> Bool) -> ConduitT Text Text m ()
forall (m :: * -> *) a. Monad m => (a -> Bool) -> ConduitT a a m ()
takeWhileC (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"---") ConduitT Text Text m ()
-> ConduitM Text Void m a -> ConduitM Text Void m a
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
    a -> ConduitT Text a m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield a
x
    Int -> ConduitT Text a m ()
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 = ConduitT Text a m (Maybe Text)
forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await ConduitT Text a m (Maybe Text)
-> (Maybe Text -> ConduitT Text a m ()) -> ConduitT Text a m ()
forall a b.
ConduitT Text a m a
-> (a -> ConduitT Text a m b) -> ConduitT Text a m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ConduitT Text a m ()
-> (Text -> ConduitT Text a m ())
-> Maybe Text
-> ConduitT Text a m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> ConduitT Text a m ()
forall a. a -> ConduitT Text a m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) Text -> ConduitT Text a m ()
start'

  start' :: Text -> ConduitT Text a m ()
start' Text
bs1 = ConduitM Text Void m a -> ConduitT Text a m a
forall (m :: * -> *) a b o.
Monad m =>
ConduitT a Void m b -> ConduitT a o m b
toConsumer (ConduitT Text Text m ()
valSrc ConduitT Text Text m ()
-> ConduitM Text Void m a -> ConduitM Text Void m a
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) ConduitT Text a m a
-> (a -> ConduitT Text a m ()) -> ConduitT Text a m ()
forall a b.
ConduitT Text a m a
-> (a -> ConduitT Text a m b) -> ConduitT Text a m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> ConduitT Text a m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield ConduitT Text a m ()
-> ConduitT Text a m () -> ConduitT Text a m ()
forall a b.
ConduitT Text a m a -> ConduitT Text a m b -> ConduitT Text a m b
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 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':') Text
bs1
    (Text
spaces, Text
bs3) = (Char -> Bool) -> Text -> (Text, Text)
T.span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') (Text -> (Text, Text)) -> Text -> (Text, Text)
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
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 = Text -> ConduitT Text Text m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield Text
bs3 ConduitT Text Text m ()
-> ConduitT Text Text m () -> ConduitT Text Text m ()
forall a b.
ConduitT Text Text m a
-> ConduitT Text Text m b -> ConduitT Text Text m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> ConduitT Text Text m ()
forall {m :: * -> *}. Monad m => Int -> ConduitT Text Text m ()
loopIndent Int
ind

  noIndent :: ConduitT Text Text m ()
noIndent = do
    Maybe Text
mx <- ConduitT Text Text m (Maybe Text)
forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await
    case Maybe Text
mx of
      Maybe Text
Nothing -> () -> ConduitT Text Text m ()
forall a. a -> ConduitT Text Text m a
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 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') Text
bs
        if Text -> Int
T.length Text
spaces Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
          then Text -> ConduitT Text Text m ()
forall i o (m :: * -> *). i -> ConduitT i o m ()
leftover Text
val
          else do
            Text -> ConduitT Text Text m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield Text
val
            Int -> ConduitT Text Text m ()
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 = ConduitT Text Text m (Maybe Text)
forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await ConduitT Text Text m (Maybe Text)
-> (Maybe Text -> ConduitT Text Text m ())
-> ConduitT Text Text m ()
forall a b.
ConduitT Text Text m a
-> (a -> ConduitT Text Text m b) -> ConduitT Text Text m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ConduitT Text Text m ()
-> (Text -> ConduitT Text Text m ())
-> Maybe Text
-> ConduitT Text Text m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> ConduitT Text Text m ()
forall a. a -> ConduitT Text Text m a
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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
T.all (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') Text
spaces =
          Text -> ConduitT Text Text m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield Text
val ConduitT Text Text m ()
-> ConduitT Text Text m () -> ConduitT Text Text m ()
forall a b.
ConduitT Text Text m a
-> ConduitT Text Text m b -> ConduitT Text Text m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ConduitT Text Text m ()
loop
      | Bool
otherwise = Text -> ConduitT Text Text m ()
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 = ConduitT a a m (Maybe a)
forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await ConduitT a a m (Maybe a)
-> (Maybe a -> ConduitT a a m ()) -> ConduitT a a m ()
forall a b.
ConduitT a a m a -> (a -> ConduitT a a m b) -> ConduitT a a m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ConduitT a a m ()
-> (a -> ConduitT a a m ()) -> Maybe a -> ConduitT a a m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> ConduitT a a m ()
forall a. a -> ConduitT a a m a
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 = a -> ConduitT a a m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield a
x ConduitT a a m () -> ConduitT a a m () -> ConduitT a a m ()
forall a b.
ConduitT a a m a -> ConduitT a a m b -> ConduitT a a m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ConduitT a a m ()
loop
    | Bool
otherwise = a -> ConduitT a a m ()
forall i o (m :: * -> *). i -> ConduitT i o m ()
leftover a
x