@@ -1,53 +1,14 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−{-# LANGUAGE RecordWildCards #-}
3−{-# LANGUAGE TupleSections #-}
4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
51
62module Main where
73
8−import Prelude hiding (userError)
9−
10−import Data.Maybe
11−import Data.Char (isSpace)
12−import Data.String (fromString)
13−import Data.List (stripPrefix, isSuffixOf, (\\), nubBy)
14−import Data.List.Split (splitOn)
15−import Data.List.NonEmpty (NonEmpty(..))
16−import Data.Version
17−import Data.Function (on)
18−import Safe (headMay)
19−
20−import qualified Data.ByteString.Lazy.Char8 as BL
21−import qualified Data.Text as T
22−
4+import Data.Version (showVersion)
235import qualified Data.Aeson as A
24−import Data.Aeson.BetterErrors
25−
26−import Control.Applicative
27−import Control.Category ((>>>))
28−import Control.Arrow ((***))
29−import Control.Exception (catch, try)
30−import Control.Monad.Trans.Except
31−import Control.Monad.Error.Class (MonadError(..))
32−import Control.Monad.Writer
6+import qualified Data.ByteString.Lazy.Char8 as BL
337
348import Options.Applicative hiding (str)
359
36−import System.Directory (doesFileExist)
37−import System.Process (readProcess)
38−import System.Exit (exitFailure)
39−import qualified System.FilePath.Glob as Glob
40−
41−import Web.Bower.PackageMeta (PackageMeta(..), BowerError(..), PackageName,
42− runPackageName, parsePackageName, Repository(..))
43−import qualified Web.Bower.PackageMeta as Bower
44−
45−import qualified Language.PureScript as P (version)
46−import qualified Language.PureScript.Docs as D
4710import qualified Paths_purescript as Paths
48−
49−import Utils
50−import ErrorsWarnings
11+import Language.PureScript.Publish (preparePackage)
5112
5213main :: IO ()
5314main = execParser opts >> publish
@@ -65,266 +26,3 @@ publish = do
6526 pkg <- preparePackage
6627 BL.putStrLn (A.encode pkg)
6728
68−-- | Attempt to retrieve package metadata from the current directory.
69−-- Calls exitFailure if no package metadata could be retrieved.
70−preparePackage :: IO D.UploadedPackage
71−preparePackage =
72− runPrepareM preparePackage'
73− >>= either (\e -> printError e >> exitFailure)
74− handleWarnings
75− where
76− handleWarnings (result, warns) = do
77− printWarnings warns
78− return result
79−
80−newtype PrepareM a =
81− PrepareM { unPrepareM :: WriterT [PackageWarning] (ExceptT PackageError IO) a }
82− deriving (Functor, Applicative, Monad,
83− MonadWriter [PackageWarning],
84− MonadError PackageError)
85−
86−-- This MonadIO instance ensures that IO errors don't crash the program.
87−instance MonadIO PrepareM where
88− liftIO act =
89− lift' (try act) >>= either (otherError . IOExceptionThrown) return
90− where
91− lift' :: IO a -> PrepareM a
92− lift' = PrepareM . lift . lift
93−
94−runPrepareM :: PrepareM a -> IO (Either PackageError (a, [PackageWarning]))
95−runPrepareM = runExceptT . runWriterT . unPrepareM
96−
97−warn :: PackageWarning -> PrepareM ()
98−warn w = tell [w]
99−
100−userError :: UserError -> PrepareM a
101−userError = throwError . UserError
102−
103−internalError :: InternalError -> PrepareM a
104−internalError = throwError . InternalError
105−
106−otherError :: OtherError -> PrepareM a
107−otherError = throwError . OtherError
108−
109−catchLeft :: Applicative f => Either a b -> (a -> f b) -> f b
110−catchLeft a f = either f pure a
111−
112−preparePackage' :: PrepareM D.UploadedPackage
113−preparePackage' = do
114− exists <- liftIO (doesFileExist "bower.json")
115− unless exists (userError BowerJSONNotFound)
116−
117− pkgMeta <- liftIO (Bower.decodeFile "bower.json")
118− >>= flip catchLeft (userError . CouldntParseBowerJSON)
119− (pkgVersionTag, pkgVersion) <- getVersionFromGitTag
120− pkgGithub <- getBowerInfo pkgMeta
121− (pkgBookmarks, pkgModules) <- getModulesAndBookmarks
122−
123− let declaredDeps = map fst (bowerDependencies pkgMeta ++
124− bowerDevDependencies pkgMeta)
125− pkgResolvedDependencies <- getResolvedDependencies declaredDeps
126−
127− let pkgUploader = D.NotYetKnown
128− let pkgCompilerVersion = P.version
129−
130− return D.Package{..}
131−
132−getModulesAndBookmarks :: PrepareM ([D.Bookmark], [D.Module])
133−getModulesAndBookmarks = do
134− (inputFiles, depsFiles) <- liftIO getInputAndDepsFiles
135− liftIO (D.parseAndDesugar inputFiles depsFiles renderModules)
136− >>= either (userError . ParseAndDesugarError) return
137− where
138− renderModules bookmarks modules =
139− return (bookmarks, map D.convertModule modules)
140−
141−getVersionFromGitTag :: PrepareM (String, Version)
142−getVersionFromGitTag = do
143− out <- readProcess' "git" ["tag", "--list", "--points-at", "HEAD"] ""
144− let vs = map trimWhitespace (lines out)
145− case mapMaybe parseMay vs of
146− [] -> userError TagMustBeCheckedOut
147− [x] -> return x
148− xs -> userError (AmbiguousVersions (map snd xs))
149− where
150− trimWhitespace =
151− dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse
152− parseMay str =
153− (str,) <$> D.parseVersion' (dropPrefix "v" str)
154− dropPrefix prefix str =
155− fromMaybe str (stripPrefix prefix str)
156−
157−getBowerInfo :: PackageMeta -> PrepareM (D.GithubUser, D.GithubRepo)
158−getBowerInfo = either (userError . BadRepositoryField) return . tryExtract
159− where
160− tryExtract pkgMeta =
161− case bowerRepository pkgMeta of
162− Nothing -> Left RepositoryFieldMissing
163− Just Repository{..} -> do
164− unless (repositoryType == "git")
165− (Left (BadRepositoryType repositoryType))
166− maybe (Left NotOnGithub) Right (extractGithub repositoryUrl)
167−
168−extractGithub :: String -> Maybe (D.GithubUser, D.GithubRepo)
169−extractGithub =
170− stripPrefix "git://github.com/"
171− >>> fmap (splitOn "/")
172− >=> takeTwo
173− >>> fmap (D.GithubUser *** (D.GithubRepo . dropDotGit))
174−
175− where
176− takeTwo :: [a] -> Maybe (a, a)
177− takeTwo [x, y] = Just (x, y)
178− takeTwo _ = Nothing
179−
180− dropDotGit :: String -> String
181− dropDotGit str
182− | ".git" `isSuffixOf` str = take (length str - 4) str
183− | otherwise = str
184−
185−readProcess' :: String -> [String] -> String -> PrepareM String
186−readProcess' prog args stdin = do
187− out <- liftIO (catch (Right <$> readProcess prog args stdin)
188− (return . Left))
189− either (otherError . ProcessFailed prog args) return out
190−
191−data DependencyStatus
192− = Missing
193− -- ^ Listed in bower.json, but not installed.
194− | NoResolution
195− -- ^ In the output of `bower list --json --offline`, there was no
196− -- _resolution key. This can be caused by adding the dependency using
197− -- `bower link`, or simply copying it into bower_components instead of
198− -- installing it normally.
199− | ResolvedOther String
200− -- ^ Resolved, but to something other than a version. The String argument
201− -- is the resolution type. The values it can take that I'm aware of are
202− -- "commit" and "branch".
203− | ResolvedVersion String
204− -- ^ Resolved to a version. The String argument is the resolution tag (eg,
205− -- "v0.1.0").
206− deriving (Show, Eq)
207−
208−-- Go through all bower dependencies which contain purescript code, and
209−-- extract their versions.
210−--
211−-- In the case where a bower dependency is taken from a particular version,
212−-- that's easy; take that version. In any other case (eg, a branch, or a commit
213−-- sha) we print a warning that documentation links will not work, and avoid
214−-- linking to documentation for any types from that package.
215−--
216−-- The rationale for this is: people will prefer to use a released version
217−-- where possible. If they are not using a released version, then this is
218−-- probably for a reason. However, docs are only ever available for released
219−-- versions. Therefore there will probably be no version of the docs which is
220−-- appropriate to link to, and we should omit links.
221−getResolvedDependencies :: [PackageName] -> PrepareM [(PackageName, Version)]
222−getResolvedDependencies declaredDeps = do
223− depsBS <- fromString <$> readProcess' "bower" ["list", "--json", "--offline"] ""
224−
225− -- Check for undeclared dependencies
226− toplevels <- catchJSON (parse asToplevelDependencies depsBS)
227− warnUndeclared declaredDeps toplevels
228−
229− deps <- catchJSON (parse asResolvedDependencies depsBS)
230− handleDeps deps
231−
232− where
233− catchJSON = flip catchLeft (internalError . JSONError FromBowerList)
234−
235−-- | Extracts all dependencies and their versions from
236−-- `bower list --json --offline`
237−asResolvedDependencies :: Parse BowerError [(PackageName, DependencyStatus)]
238−asResolvedDependencies = nubBy ((==) `on` fst) <$> go
239− where
240− go =
241− fmap (fromMaybe []) $
242− keyMay "dependencies" $
243− (++) <$> eachInObjectWithKey (parsePackageName . T.unpack)
244− asDependencyStatus
245− <*> (concatMap snd <$> eachInObject asResolvedDependencies)
246−
247−-- | Extracts only the top level dependency names from the output of
248−-- `bower list --json --offline`
249−asToplevelDependencies :: Parse BowerError [PackageName]
250−asToplevelDependencies =
251− fmap (map fst) $
252− key "dependencies" $
253− eachInObjectWithKey (parsePackageName . T.unpack) (return ())
254−
255−asDependencyStatus :: Parse e DependencyStatus
256−asDependencyStatus = do
257− isMissing <- keyOrDefault "missing" False asBool
258− if isMissing
259− then
260− return Missing
261− else
262− key "pkgMeta" $
263− keyOrDefault "_resolution" NoResolution $ do
264− type_ <- key "type" asString
265− case type_ of
266− "version" -> ResolvedVersion <$> key "tag" asString
267− other -> return (ResolvedOther other)
268−
269−warnUndeclared :: [PackageName] -> [PackageName] -> PrepareM ()
270−warnUndeclared declared actual =
271− mapM_ (warn . UndeclaredDependency) (actual \\ declared)
272−
273−handleDeps ::
274− [(PackageName, DependencyStatus)] -> PrepareM [(PackageName, Version)]
275−handleDeps deps = do
276− let (missing, noVersion, installed) = partitionDeps deps
277− case missing of
278− (x:xs) ->
279− userError (MissingDependencies (x :| xs))
280− [] -> do
281− mapM_ (warn . NoResolvedVersion) noVersion
282− withVersions <- catMaybes <$> mapM tryExtractVersion' installed
283− filterM (liftIO . isPureScript . bowerDir . fst) withVersions
284−
285− where
286− partitionDeps = foldr go ([], [], [])
287− go (pkgName, d) (ms, os, is) =
288− case d of
289− Missing -> (pkgName : ms, os, is)
290− NoResolution -> (ms, pkgName : os, is)
291− ResolvedOther _ -> (ms, pkgName : os, is)
292− ResolvedVersion v -> (ms, os, (pkgName, v) : is)
293−
294− bowerDir pkgName = "bower_components/" ++ runPackageName pkgName
295−
296− -- Try to extract a version, and warn if unsuccessful.
297− tryExtractVersion' pair =
298− maybe (warn (UnacceptableVersion pair) >> return Nothing)
299− (return . Just)
300− (tryExtractVersion pair)
301−
302−tryExtractVersion :: (PackageName, String) -> Maybe (PackageName, Version)
303−tryExtractVersion (pkgName, tag) =
304− let tag' = fromMaybe tag (stripPrefix "v" tag)
305− in (pkgName,) <$> D.parseVersion' tag'
306−
307−-- | Returns whether it looks like there is a purescript package checked out
308−-- in the given directory.
309−isPureScript :: FilePath -> IO Bool
310−isPureScript dir = do
311− files <- Glob.globDir1 purescriptSourceFiles dir
312− return (not (null files))
313−
314−getInputAndDepsFiles :: IO ([FilePath], [(PackageName, FilePath)])
315−getInputAndDepsFiles = do
316− inputFiles <- globRelative purescriptSourceFiles
317− depsFiles' <- globRelative purescriptDepsFiles
318− return (inputFiles, mapMaybe withPackageName depsFiles')
319−
320−withPackageName :: FilePath -> Maybe (PackageName, FilePath)
321−withPackageName fp = (,fp) <$> getPackageName fp
322−
323−getPackageName :: FilePath -> Maybe PackageName
324−getPackageName fp = do
325− let xs = splitOn "/" fp
326− ys <- stripPrefix ["bower_components"] xs
327− y <- headMay ys
328− case Bower.mkPackageName y of
329− Right name -> Just name
330− Left _ -> Nothing