stack-hpc-coveralls 0.0.3.0 → 0.0.4.0

raw patch · 9 files changed

+202/−76 lines, 9 filesdep +directorydep +unordered-containersdep +yamlPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: directory, unordered-containers, yaml

API changes (from Hackage documentation)

Files

• USAGE.txt +6/−0
• app/Main.hs +14/−9
• src/SHC/Api.hs +15/−7
• src/SHC/Coverage.hs +20/−15
• src/SHC/Stack.hs +74/−0
• src/SHC/Types.hs +52/−9
• src/SHC/Utils.hs +1/−20
• stack-hpc-coveralls.cabal +19/−15
• stack.yaml +1/−1

@@ -8,3 +8,9 @@     --repo-token=<token>  Coveralls repo token     --partial-coverage    allow partial line coverage     --dont-send           display Coveralls JSON instead of sending it+    --fetch-coverage      fetch and display Coveralls's overall coverage++Multiple packages:+     Use "combined" and "all" as package-name and suite-name resp. in+order to use all packages that stack has tested from a multiple+package repo.

@@ -3,7 +3,7 @@ module Main     where -import           Control.Monad         (unless)+import           Control.Monad         (unless, when) import           Data.Aeson            (encode) import qualified Data.ByteString.Lazy  as BSL import           Data.List             (find)@@ -18,6 +18,7 @@  import           SHC.Api import           SHC.Coverage+import           SHC.Stack import           SHC.Types import           SHC.Utils @@ -56,16 +57,19 @@     unless (not $ null suites) $         putStrLn "Error: provide at least one test-suite name" >> exitFailure     (sn, jId) <- getServiceAndJobId-    Config <$> pure suites+    Config <$> pure pn+           <*> pure suites            <*> pure sn            <*> pure jId            <*> pure (args `getArg` longOption "repo-token")            <*> getGitInfo            <*> defaultOr args (longOption "hpc-dir") (getHpcDir pn)-           <*> defaultOr args (longOption "hpc-dir") getMixDir+           <*> pure (args `getArg` longOption "mix-dir")            <*> pure (if args `isPresent` longOption "partial-coverage"                         then PartialLines                         else FullLines)+           <*> getStackProjects+           <*> pure (args `isPresent` longOption "fetch-coverage")  main :: IO () main = do@@ -84,12 +88,13 @@              PostSuccess u -> do                  let apiUrl = u ++ ".json"                  putStrLn $ "Job URL: " ++ apiUrl-                 -- wait 5 seconds until the page is available-                 threadDelay $ 5 * 1000 * 1000-                 coverageResult <- readCoverageResult apiUrl-                 case coverageResult of-                     Just totalCov -> putStrLn $ "Coverage: " ++ show totalCov-                     Nothing       -> putStrLn "Failed to read total coverage"+                 when (fetchCoverage conf) $ do+                     -- wait 5 seconds until the page is available+                     threadDelay $ 5 * 1000 * 1000+                     coverageResult <- readCoverageResult apiUrl+                     case coverageResult of+                         Just totalCov -> putStrLn $ "Coverage: " ++ show totalCov+                         Nothing       -> putStrLn "Failed to read total coverage"              PostFailure msg -> do                  putStrLn $ "Error: " ++ msg                  exitFailure

@@ -15,6 +15,7 @@     where  import           Codec.Binary.UTF8.String              (decode)+import           Control.Exception                     (catch) import           Data.Aeson                            (Value, encode) import           Data.Aeson.Lens                       (key, _Double, _String) import qualified Data.ByteString                       as BS@@ -38,21 +39,28 @@          -> Value         -- ^ The JSON object          -> IO PostResult sendData conf url json = do-    r <- post url [partFileRequestBody "json_file" fileName requestBody]+    r <- postWith httpOptions url [partFileRequestBody "json_file" fileName requestBody]     if r ^. responseStatus . statusCode == 200        then return $ readResponse r-       else return . PostFailure $-           "Error: " ++ decode (BS.unpack $ r ^. responseStatus . statusMessage)+       else return . PostFailure $ formatResponseError r     where fileName    = serviceName conf ++ "-" ++ jobId conf ++ ".json"           requestBody = RequestBodyLBS $ encode json+          httpOptions = defaults & checkStatus .~ Just noCheck+          noCheck _ _ _ = Nothing  readResponse :: Response LBS.ByteString -> PostResult readResponse r =     case r ^? responseBody . key "error" . _String of-      Just err -> PostFailure $ T.unpack err-      Nothing  -> case r ^? responseBody . key "url" . _String of-                    Just url -> PostSuccess $ T.unpack url-                    Nothing  -> PostFailure "Error: malformed response body"+      Just _  -> PostFailure $ formatResponseError r+      Nothing -> case r ^? responseBody . key "url" . _String of+                   Just url -> PostSuccess $ T.unpack url+                   Nothing  -> PostFailure "Error: malformed response body"++formatResponseError :: Response LBS.ByteString -> String+formatResponseError r =+    "Coveralls returned HTTP " ++ show (r ^. responseStatus . statusCode) +++    " " ++ decode (BS.unpack $ r ^. responseStatus . statusMessage) ++ "\n" +++    decode (LBS.unpack $ r ^. responseBody)  -- | Read the coverage results from Coveralls.io. readCoverageResult :: String -> IO (Maybe Double)

@@ -19,23 +19,25 @@ #endif import           Data.Aeson import           Data.Aeson.Types           ()+import qualified Data.ByteString.Char8      as BS import qualified Data.ByteString.Lazy.Char8 as LBS import           Data.Digest.Pure.MD5 import           Data.Function import           Data.List+import           Data.Maybe                 (fromMaybe) import qualified Data.Map.Strict            as M import           SHC.Lix import           SHC.Types import           SHC.Utils import           System.Exit                (exitFailure)-import           System.FilePath            ((</>))+import           System.FilePath            ((</>), normalise) import           Trace.Hpc.Mix import           Trace.Hpc.Tix import           Trace.Hpc.Util -type ModuleCoverageData = ( String     -- file source code-                          , Mix        -- module index data-                          , [Integer]  -- tixs recorded by HPC+type ModuleCoverageData = ( BS.ByteString -- file source code+                          , Mix           -- module index data+                          , [Integer]     -- tixs recorded by HPC                           )  type TestSuiteCoverageData = M.Map FilePath ModuleCoverageData@@ -61,9 +63,6 @@     None       -> Number 0     Irrelevant -> Null -readMix' :: Config -> TixModule -> IO Mix-readMix' conf tix = readMix [SHC.Types.mixDir conf] (Right tix)- -- | Generate Coveralls JSON formatted code coverage from HPC coverage data generateCoverallsFromTix :: Config -> IO Value generateCoverallsFromTix conf = do@@ -84,13 +83,18 @@         Nothing -> putStrLn ("Couldn't find the file " ++ tixPath) >>                    exitFailure         Just (Tix tixs) -> do-            mixs <- mapM (readMix' conf) tixs-            let files = map filePath mixs-            sources <- mapM readFile files-            let coverageData = zip4 files sources mixs (map tixModuleTixs tixs)+            coverageData <- mapM getCoverageData tixs             let filteredCoverageData = filter sourceDirFilter coverageData             return $ M.fromList $ map toFirstAndRest filteredCoverageData-            where filePath (Mix fp _ _ _ _) = fp+            where getCoverageData tixModule@(TixModule modName _ _ tixs) = do+                    let pkgKey = takeWhile (/= '/') modName+                        stackProj =+                          fromMaybe (error $ "readCoverageData/filePath/stackProj: couldn't find " ++ pkgKey) $+                          find ((== pkgKey) . stackProjectKey) (stackProjects conf)+                    mix@(Mix origFp _ _ _ _) <- readMix [fromMaybe (stackProjectMixDir stackProj) (mixDir conf)] (Right tixModule)+                    let fp = normalise $ maybe id (</>) (stackProjectPath stackProj) origFp+                    source <- BS.readFile fp+                    return (fp, source, mix, tixs)                   sourceDirFilter = not . matchAny excludeDirPatterns . fst4                   excludeDirPatterns = []  -- XXX: for now @@ -110,15 +114,16 @@ coverageToJson :: LixConverter -> FilePath -> ModuleCoverageData -> Value coverageToJson converter path (source, mix, tixs) =     object [ "name"          .= path-           , "source_digest" .= (show . md5 . LBS.pack) source+           , "source_digest" .= (show . md5 . LBS.fromStrict) source            , "coverage"      .= coverage            ]     where coverage = toSimpleCoverage converter lineCount mixEntriesTixs-          lineCount = length $ lines source+          sourceLines = BS.lines source+          lineCount = length sourceLines           mixEntriesTixs = groupMixEntryTixs mixEntryTixs           mixEntryTixs = zip3 mixEntries tixs (map getExprSource' mixEntries)           Mix _ _ _ _ mixEntries = mix-          getExprSource' = getExprSource $ lines source+          getExprSource' = getExprSource $ map BS.unpack sourceLines  mergeCoverageData :: [TestSuiteCoverageData] -> TestSuiteCoverageData mergeCoverageData = foldr1 $ M.unionWith mergeModule

@@ -0,0 +1,74 @@+{-# LANGUAGE CPP #-}+-- |+-- Module:      SHC.Stack+-- Copyright:   (c) 2014-2015 Guillaume Nargeot, (c) 2015-2016 Felipe Lessa+-- License:     BSD3+-- Maintainer:  Michele Lacchia <michelelacchia@gmail.com>+-- Stability:   experimental+--+-- Utility functions related to Stack.++module SHC.Stack+    where++import Data.Version+#if __GLASGOW_HASKELL__ < 710+import Control.Applicative ((<$>), (<*>))+#endif+import Control.Monad (forM, guard)+import System.Directory (makeRelativeToCurrentDirectory)+import System.FilePath ((</>), equalFilePath)++import qualified Data.ByteString.Char8 as BS8+import qualified Data.Yaml as Y++import SHC.Types+import SHC.Utils+++stack :: [String] -> IO String+stack = readP "stack"++-- | Verify that the required Stack is present.+checkStackVersion :: IO Bool+checkStackVersion = do+    let lowerBound = Version [0,1,7,0] []+    stackVersion <- stack ["--numeric-version"]+    return $ verifyVersion stackVersion lowerBound++-- | Return the HPC data directory, given the package name.+getHpcDir :: String -> IO FilePath+getHpcDir package = (</> package) <$> stack ["path", "--local-hpc-root"]++-- | Return the HPC mix directory, where module data is stored.  This+-- path needs to be prefixed with the project's path+-- (cf. 'stackProjectPath').+getBaseMixDir :: IO FilePath+getBaseMixDir = (</> "hpc") <$> stack ["path", "--dist-dir"]++-- | Get relevant information from @stack query@.  Used to find+-- package filepaths.+getStackQuery :: IO StackQuery+getStackQuery = (Y.decodeEither' . BS8.pack <$> stack ["query"]) >>= either err return+  where err = fail . (++) "getStackQuery: Couldn't decode the result of 'stack query' as YAML: " . show++-- | Get the key that GHC uses for the given package.+getProjectKey :: String -> IO String+getProjectKey pkgName = stack ["exec", "--", "ghc-pkg", "field", pkgName, "key", "--simple-output"]++-- | Get the Stack info needed to find project files.+getStackProjects :: IO [StackProject]+getStackProjects = do+  sq <- getStackQuery+  baseMixDir <- getBaseMixDir+  forM (stackQueryLocals sq) $ \(pkgName, filepath) -> do+    relfp <- makeRelativeToCurrentDirectory filepath+    let mpath = guard (not $ relfp `equalFilePath` ".") >> Just relfp+    key <- getProjectKey pkgName+    return+      StackProject+        { stackProjectName   = pkgName+        , stackProjectPath   = mpath+        , stackProjectKey    = key+        , stackProjectMixDir = maybe id (</>) mpath baseMixDir+        }

@@ -1,12 +1,19 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP, OverloadedStrings #-}  module SHC.Types     where +import           Control.Monad (forM) import           Data.Aeson+import qualified Data.HashMap.Strict as HM+import qualified Data.Text           as T import           Trace.Hpc.Mix +#if __GLASGOW_HASKELL__ < 710+import Control.Applicative ((<$>))+#endif + data ConversionType = FullLines                     | PartialLines                     deriving (Show, Eq)@@ -30,14 +37,17 @@                 deriving (Show)  data Config = Config-    { suitesName  :: [String]-    , serviceName :: String-    , jobId       :: String-    , repoToken   :: Maybe String-    , gitInfo     :: GitInfo-    , hpcDir      :: FilePath-    , mixDir      :: FilePath-    , conversion  :: ConversionType+    { packageName   :: String+    , suitesName    :: [String]+    , serviceName   :: String+    , jobId         :: String+    , repoToken     :: Maybe String+    , gitInfo       :: GitInfo+    , hpcDir        :: FilePath+    , mixDir        :: Maybe FilePath+    , conversion    :: ConversionType+    , stackProjects :: [StackProject]+    , fetchCoverage :: Bool     }  data GitInfo = GitInfo@@ -79,3 +89,36 @@     toJSON r = object [ "name" .= name r                       , "url"  .= url r                       ]++-- | Data returned by the @stack query@ command.+data StackQuery =+  StackQuery+  { stackQueryLocals :: [(String, FilePath)]+    -- ^ A list of pairs of @(package-name, filepath)@, where the+    -- @filepath@ is the absolute 'FilePath' where @package-name@ is+    -- located.+  } deriving (Show)++instance FromJSON StackQuery where+  parseJSON = withObject "StackQuery" $ \o -> StackQuery <$> (o .: "locals" >>= parseLocals)+    where+      parseLocals =+        withObject "StackQuery/locals" $ \o ->+          forM (HM.toList o) $ \(pkgName, val) -> do+            filepath <- withObject "StackQuery/locals/package" (.: "path") val+            return (T.unpack pkgName, filepath)+++-- | Information we've collected about a stack project.+data StackProject =+  StackProject+  { stackProjectName   :: String+    -- ^ The name of this project.+  , stackProjectPath   :: Maybe FilePath+    -- ^ Path of the project relative to current path.  @Nothing@ iff+    -- the project's path is the current path.+  , stackProjectKey    :: String+    -- ^ Key that @ghc-pkg@ uses for this project.+  , stackProjectMixDir :: FilePath+    -- ^ The project's mix dir (cf. 'getMixDir').+  } deriving (Show)

@@ -19,7 +19,6 @@ import           Control.Applicative ((<$>), (<*>)) #endif import           Text.ParserCombinators.ReadP-import           System.FilePath     ((</>)) import           System.Process      (readProcess)  import           SHC.Types@@ -31,9 +30,6 @@ git :: [String] -> IO String git = readP "git" -stack :: [String] -> IO String-stack = readP "stack"- -- | Get information about the Git repo in the current directory. getGitInfo :: IO GitInfo getGitInfo = GitInfo <$> headRef <*> branchName <*> getRemotes@@ -46,7 +42,7 @@           branchName = git ["rev-parse", "--abbrev-ref", "HEAD"]  getRemotes :: IO [Remote]-getRemotes = nubBy ((==) `on` name) <$> parseRemotes <$> git ["remote", "-v"]+getRemotes = nubBy ((==) `on` name) . parseRemotes <$> git ["remote", "-v"]     where parseRemotes :: String -> [Remote]           parseRemotes input = do             line <- lines input@@ -54,27 +50,12 @@             guard $ length fields >= 2             return $ Remote (head fields) (fields !! 1) --- | Verify that the required Stack is present.-checkStackVersion :: IO Bool-checkStackVersion = do-    let lowerBound = Version [0,1,7,0] []-    stackVersion <- stack ["--numeric-version"]-    return $ verifyVersion stackVersion lowerBound- -- | Check whether a string is a version and if it is -- greater than or equal to a specified version. verifyVersion :: String -> Version -> Bool verifyVersion ver lowerBound =         let parses = readP_to_S parseVersion ver         in  not (null parses) && (lowerBound <= fst (last parses))---- | Return the HPC data directory, given the package name.-getHpcDir :: String -> IO FilePath-getHpcDir package = (</> package) <$> stack ["path", "--local-hpc-root"]---- | Return the HPC mix directory, where module data is stored.-getMixDir :: IO FilePath-getMixDir = (</> "hpc") <$> stack ["path", "--dist-dir"]  fst3 :: (a, b, c) -> a fst3 (x, _, _) = x

@@ -1,5 +1,5 @@ name:                stack-hpc-coveralls-version:             0.0.3.0+version:             0.0.4.0 synopsis:            Initial project template from stack description:         Please see README.md homepage:            http://github.com/rubik/stack-hpc-coveralls@@ -22,20 +22,24 @@                        SHC.Utils                        SHC.Lix                        SHC.Api-  build-depends:       base           >=4.7  && <5-                     , hpc            >=0.6-                     , filepath       >=1.3-                     , process        >=1.2-                     , pureMD5        >=2.1-                     , containers     >=0.5-                     , aeson          >=0.8-                     , bytestring     >=0.10-                     , utf8-string    >=1-                     , text           >=1.2-                     , wreq           >=0.3-                     , http-client    >=0.4-                     , lens           >=4.7-                     , lens-aeson     >=1.0+                       SHC.Stack+  build-depends:       base                 >=4.7  && <5+                     , hpc                  >=0.6+                     , directory            >=1.0+                     , filepath             >=1.3+                     , process              >=1.2+                     , pureMD5              >=2.1+                     , containers           >=0.5+                     , aeson                >=0.8+                     , bytestring           >=0.10+                     , unordered-containers >=0.2+                     , utf8-string          >=1+                     , text                 >=1.2+                     , wreq                 >=0.3+                     , http-client          >=0.4+                     , lens                 >=4.7+                     , lens-aeson           >=1.0+                     , yaml                 >=0.8   default-language:    Haskell2010  executable shc

@@ -1,7 +1,7 @@ # For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md  # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)-resolver: lts-3.11+resolver: nightly-2016-06-15  # Local packages, usually specified by relative directory name packages: