Browse Source

Initial package dump parsing #166

Don't be afraid of the diff size, most of it is GHC dump output for
tests
docs-docker
Michael Snoyman 7 years ago
parent
commit
7d94335aef
  1. 167
      src/Stack/PackageDump.hs
  2. 99
      src/test/Stack/PackageDumpSpec.hs
  3. 4
      stack.cabal
  4. 1188
      test/package-dump/ghc-7.10.txt
  5. 1529
      test/package-dump/ghc-7.8.txt

167
src/Stack/PackageDump.hs

@ -0,0 +1,167 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE DeriveDataTypeable #-}
module Stack.PackageDump
( Line
, eachSection
, eachPair
, DumpPackage (..)
, conduitDumpPackage
) where
import Control.Monad.Catch (MonadThrow, Exception, throwM)
import Control.Monad (when)
import Stack.Types
import Data.ByteString (ByteString)
import qualified Data.ByteString as S
import Data.Conduit
import Data.Typeable (Typeable)
import qualified Data.Conduit.List as CL
import qualified Data.Conduit.Binary as CB
import qualified Data.Map as Map
import Control.Applicative ((<$>), (<*>))
import Data.Maybe (catMaybes)
-- | Dump information for a single package
data DumpPackage = DumpPackage
{ dpGhcPkgId :: !GhcPkgId
, dpLibDirs :: ![ByteString]
, dpDepends :: ![(GhcPkgId, BuiltinRts)]
}
deriving (Show, Eq, Ord)
type BuiltinRts = Bool
data PackageDumpException
= MissingSingleField ByteString
| MissingMultiField ByteString
| MismatchedId PackageName Version GhcPkgId
deriving (Show, Typeable)
instance Exception PackageDumpException
-- | Convert a stream of bytes into a stream of @DumpPackage@s
conduitDumpPackage :: MonadThrow m => Conduit ByteString m DumpPackage
conduitDumpPackage = (=$= CL.catMaybes) $ eachSection $ do
pairs <- eachPair (\k -> (k, ) <$> CL.consume) =$= CL.consume
let m = Map.fromList pairs
let parseS k =
case Map.lookup k m of
Just [v] -> return v
_ -> throwM $ MissingSingleField k
parseM k =
case Map.lookup k m of
Just vs -> return vs
Nothing -> throwM $ MissingMultiField k
parseDepend "builtin_rts" = return Nothing
parseDepend bs =
(Just . (, builtinRts)) <$> parseGhcPkgId bs'
where
(bs', builtinRts) =
case stripSuffixBS " builtin_rts" bs of
Nothing ->
case stripPrefixBS "builtin_rts " bs of
Nothing -> (bs, False)
Just x -> (x, True)
Just x -> (x, True)
case Map.lookup "id" m of
Just ["builtin_rts"] -> return Nothing
_ -> do
name <- parseS "name" >>= parsePackageName
version <- parseS "version" >>= parseVersion
ghcPkgId <- parseS "id" >>= parseGhcPkgId
when (PackageIdentifier name version /= ghcPkgIdPackageIdentifier ghcPkgId)
$ throwM $ MismatchedId name version ghcPkgId
libDirs <- parseM "library-dirs"
depends <- parseM "depends" >>= mapM parseDepend
return $ Just DumpPackage
{ dpGhcPkgId = ghcPkgId
, dpLibDirs = libDirs
, dpDepends = catMaybes depends
}
stripPrefixBS x y
| x `S.isPrefixOf` y = Just $ S.drop (S.length x) y
| otherwise = Nothing
stripSuffixBS x y
| x `S.isSuffixOf` y = Just $ S.take (S.length y - S.length x) y
| otherwise = Nothing
-- | A single line of input, not including line endings
type Line = ByteString
-- | Apply the given Sink to each section of output, broken by a single line containing ---
eachSection :: Monad m
=> Sink Line m a
-> Conduit ByteString m a
eachSection inner =
CL.map (S.filter (/= _cr)) =$= CB.lines =$= start
where
_cr = 13
start = CL.peek >>= maybe (return ()) (const go)
go = do
x <- toConsumer $ takeWhileC (/= "---") =$= inner
yield x
CL.drop 1
start
-- | Grab each key/value pair
eachPair :: Monad m
=> (ByteString -> Sink Line m a)
-> Conduit Line m a
eachPair inner =
start
where
start = await >>= maybe (return ()) start'
_colon = 58
_space = 32
start' bs1 =
toConsumer (valSrc =$= inner key) >>= yield >> start
where
(key, bs2) = S.breakByte _colon bs1
(spaces, bs3) = S.span (== _space) $ S.drop 1 bs2
indent = S.length key + 1 + S.length spaces
valSrc
| S.null bs3 = noIndent
| otherwise = yield bs3 >> loopIndent indent
noIndent = do
mx <- await
case mx of
Nothing -> return ()
Just bs -> do
let (spaces, val) = S.span (== _space) bs
if S.length spaces == 0
then leftover val
else do
yield val
loopIndent (S.length spaces)
loopIndent i =
loop
where
loop = await >>= maybe (return ()) go
go bs
| S.length spaces == i && S.all (== _space) spaces =
yield val >> loop
| otherwise = leftover bs
where
(spaces, val) = S.splitAt i bs
-- | General purpose utility
takeWhileC :: Monad m => (a -> Bool) -> Conduit a m a
takeWhileC f =
loop
where
loop = await >>= maybe (return ()) go
go x
| f x = yield x >> loop
| otherwise = leftover x

99
src/test/Stack/PackageDumpSpec.hs

@ -0,0 +1,99 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
module Stack.PackageDumpSpec where
import Data.Conduit
import qualified Data.Conduit.List as CL
import qualified Data.Conduit.Binary as CB
import Control.Monad.Trans.Resource (runResourceT)
import Stack.PackageDump
import Stack.Types
import Test.Hspec
main :: IO ()
main = hspec spec
spec :: Spec
spec = do
describe "eachSection" $ do
let test name content expected = it name $ do
actual <- yield content $$ eachSection CL.consume =$ CL.consume
actual `shouldBe` expected
test
"unix line endings"
"foo\nbar\n---\nbaz---\nbin\n---\n"
[ ["foo", "bar"]
, ["baz---", "bin"]
]
test
"windows line endings"
"foo\r\nbar\r\n---\r\nbaz---\r\nbin\r\n---\r\n"
[ ["foo", "bar"]
, ["baz---", "bin"]
]
it "eachPair" $ do
let bss =
[ "key1: val1"
, "key2: val2a"
, " val2b"
, "key3:"
, "key4:"
, " val4a"
, " val4b"
]
sink k = fmap (k, ) CL.consume
actual <- mapM_ yield bss $$ eachPair sink =$ CL.consume
actual `shouldBe`
[ ("key1", ["val1"])
, ("key2", ["val2a", "val2b"])
, ("key3", [])
, ("key4", ["val4a", "val4b"])
]
describe "conduitDumpPackage" $ do
it "ghc 7.8" $ do
haskell2010:_ <- runResourceT
$ CB.sourceFile "test/package-dump/ghc-7.8.txt"
$$ conduitDumpPackage
=$ CL.consume
ghcPkgId <- parseGhcPkgId "haskell2010-1.1.2.0-05c8dd51009e08c6371c82972d40f55a"
depends <- mapM parseGhcPkgId
[ "array-0.5.0.0-470385a50d2b78598af85cfe9d988e1b"
, "base-4.7.0.2-bfd89587617e381ae01b8dd7b6c7f1c1"
, "ghc-prim-0.3.1.0-a24f9c14c632d75b683d0f93283aea37"
]
haskell2010 `shouldBe` DumpPackage
{ dpGhcPkgId = ghcPkgId
, dpLibDirs = ["/opt/ghc/7.8.4/lib/ghc-7.8.4/haskell2010-1.1.2.0"]
, dpDepends = map (, False) depends
}
it "ghc 7.10" $ do
haskell2010:_ <- runResourceT
$ CB.sourceFile "test/package-dump/ghc-7.10.txt"
$$ conduitDumpPackage
=$ CL.consume
ghcPkgId <- parseGhcPkgId "ghc-7.10.1-325809317787a897b7a97d646ceaa3a3"
depends <- mapM parseGhcPkgId
[ "array-0.5.1.0-e29cdbe82692341ebb7ce6e2798294f9"
, "base-4.8.0.0-1b689eb8d72c4d4cc88f445839c1f01a"
, "bin-package-db-0.0.0.0-708fc7d634a370b311371a5bcde40b62"
, "bytestring-0.10.6.0-0909f8f31271f3d75749190bf2ee35db"
, "containers-0.5.6.2-2114032c163425cc264e6e1169dc2f6d"
, "directory-1.2.2.0-b4959b472d9eee380c6b32291ade29e0"
, "filepath-1.4.0.0-40d643aa87258c186441a1f8f3e13ca6"
, "hoopl-3.10.0.2-8c8dfc4c3140e5f7c982da224c3cb1f0"
, "hpc-0.6.0.2-ac9064885aa8cb08a93314222939ead4"
, "process-1.2.3.0-3b1e9bca6ac38225806ff7bbf3f845b1"
, "template-haskell-2.10.0.0-e895139a0ffff267d412e3d0191ce93b"
, "time-1.5.0.1-e17a9220d438435579d2914e90774246"
, "transformers-0.4.2.0-c1a7bb855a176fe475d7b665301cd48f"
, "unix-2.7.1.0-e5915eb989e568b732bc7286b0d0817f"
]
haskell2010 `shouldBe` DumpPackage
{ dpGhcPkgId = ghcPkgId
, dpLibDirs = ["/opt/ghc/7.10.1/lib/ghc-7.10.1/ghc_EMlWrQ42XY0BNVbSrKixqY"]
, dpDepends = map (, False) depends
}

4
stack.cabal

@ -14,7 +14,7 @@ copyright: 2015 FP Complete
category: Development
build-type: Simple
cabal-version: >=1.10
extra-source-files: README.md ARCHITECTURE.md ChangeLog.md
extra-source-files: README.md ARCHITECTURE.md ChangeLog.md test/package-dump/*.txt
library
hs-source-dirs: src/
@ -28,6 +28,7 @@ library
Stack.Fetch
Stack.GhcPkg
Stack.Package
Stack.PackageDump
Stack.PackageIndex
Stack.Setup
Stack.Types
@ -157,6 +158,7 @@ test-suite stack-test
other-modules: Spec
, Stack.BuildPlanSpec
, Stack.ConfigSpec
, Stack.PackageDumpSpec
ghc-options: -Wall -O2
extensions: FlexibleContexts
build-depends: base >=4.7 && <5

1188
test/package-dump/ghc-7.10.txt

File diff suppressed because it is too large

1529
test/package-dump/ghc-7.8.txt

File diff suppressed because it is too large
Loading…
Cancel
Save