Merge pull request purescript#1108 from hdgarrood/docs-add-version-tag

paf31 · paf31 · commit 9bd56d9b638e · 2015-05-07T08:35:46.000-07:00
Add versionTag to psc-publish output
diff --git a/psc-publish/Main.hs b/psc-publish/Main.hs
@@ -97,12 +97,13 @@ preparePackage' = do
 
   pkgMeta <- liftIO (Bower.decodeFile "bower.json")
                     >>= flip catchLeft (userError . CouldntParseBowerJSON)
-  pkgVersion                 <- getVersionFromGitTag
-  pkgGithub                  <- getBowerInfo pkgMeta
-  (pkgBookmarks, pkgModules) <- getModulesAndBookmarks
+  (pkgVersionTag, pkgVersion) <- getVersionFromGitTag
+  pkgGithub                   <- getBowerInfo pkgMeta
+  (pkgBookmarks, pkgModules)  <- getModulesAndBookmarks
 
-  let declaredDeps = map fst (bowerDependencies pkgMeta ++ bowerDevDependencies pkgMeta)
-  pkgResolvedDependencies    <- getResolvedDependencies declaredDeps
+  let declaredDeps = map fst (bowerDependencies pkgMeta ++
+                              bowerDevDependencies pkgMeta)
+  pkgResolvedDependencies     <- getResolvedDependencies declaredDeps
 
   let pkgUploader = D.NotYetKnown
 
@@ -117,19 +118,19 @@ getModulesAndBookmarks = do
   renderModules bookmarks modules =
     return (bookmarks, map D.renderModule modules)
 
-getVersionFromGitTag :: PrepareM Version
+getVersionFromGitTag :: PrepareM (String, Version)
 getVersionFromGitTag = do
   out <- readProcess' "git" ["tag", "--list", "--points-at", "HEAD"] ""
-  let vs = map clean (lines out)
-  case mapMaybe D.parseVersion' vs of
+  let vs = map trimWhitespace (lines out)
+  case mapMaybe parseMay vs of
     []  -> userError TagMustBeCheckedOut
     [x] -> return x
-    xs  -> userError (AmbiguousVersions xs)
+    xs  -> userError (AmbiguousVersions (map snd xs))
   where
-  clean =
-    trimWhitespace >>> dropPrefix "v"
   trimWhitespace =
     dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse
+  parseMay str =
+    (str,) <$> D.parseVersion' (dropPrefix "v" str)
   dropPrefix prefix str =
     fromMaybe str (stripPrefix prefix str)
 
diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs
@@ -38,6 +38,7 @@ import Language.PureScript.Docs.RenderedCode as ReExports
 data Package a = Package
   { pkgMeta                 :: PackageMeta
   , pkgVersion              :: Version
+  , pkgVersionTag           :: String
   , pkgModules              :: [RenderedModule]
   , pkgBookmarks            :: [Bookmark]
   , pkgResolvedDependencies :: [(PackageName, Version)]
@@ -56,6 +57,7 @@ verifyPackage :: GithubUser -> UploadedPackage -> VerifiedPackage
 verifyPackage verifiedUser Package{..} =
   Package pkgMeta
           pkgVersion
+          pkgVersionTag
           pkgModules
           pkgBookmarks
           pkgResolvedDependencies
@@ -156,6 +158,7 @@ asPackage :: (forall e. Parse e a) -> Parse PackageError (Package a)
 asPackage uploader =
   Package <$> key "packageMeta" asPackageMeta .! ErrorInPackageMeta
           <*> key "version" asVersion
+          <*> key "versionTag" asString
           <*> key "modules" (eachInArray asRenderedModule)
           <*> key "bookmarks" asBookmarks .! ErrorInPackageMeta
           <*> key "resolvedDependencies" asResolvedDependencies
@@ -263,6 +266,7 @@ instance A.ToJSON a => A.ToJSON (Package a) where
     A.object $
       [ "packageMeta"          .= pkgMeta
       , "version"              .= showVersion pkgVersion
+      , "versionTag"           .= pkgVersionTag
       , "modules"              .= pkgModules
       , "bookmarks"            .= map (fmap (first P.runModuleName)) pkgBookmarks
       , "resolvedDependencies" .= assocListToJSON (T.pack . runPackageName)
