{-# 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
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
"."
]
ghcPkgDump
:: (HasProcessContext env, HasLogFunc env)
=> GhcPkgExe
-> [Path Abs Dir]
-> 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"]
ghcPkgDescribe
:: (HasProcessContext env, HasLogFunc env, HasCompiler env)
=> GhcPkgExe
-> PackageName
-> [Path Abs Dir]
-> 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']
ghcPkgCmdArgs
:: (HasProcessContext env, HasLogFunc env)
=> GhcPkgExe
-> [String]
-> [Path Abs Dir]
-> 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
[Path Abs Dir]
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
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
pruneDeps
:: (Ord name, Ord id)
=> (id -> name)
-> (item -> id)
-> (item -> [id])
-> (item -> item -> item)
-> [item]
-> 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'
sinkMatching :: Monad m
=> Map PackageName Version
-> 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
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
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
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
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"
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)
, 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
type Line = Text
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
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
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