Skip to content

Commit 5725ebf

Browse files
hdgarroodhdgarrood
committed
Move psc-publish code into a library
1 parent da99bc1 commit 5725ebf

File tree

6 files changed

+325
-321
lines changed

6 files changed

+325
-321
lines changed

‎psc-publish/Main.hs‎

Lines changed: 3 additions & 305 deletions
Original file line numberDiff line numberDiff line change
@@ -1,53 +1,14 @@
1-
{-# LANGUAGE OverloadedStrings #-}
2-
{-# LANGUAGE RecordWildCards #-}
3-
{-# LANGUAGE TupleSections #-}
4-
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
51

62
module 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)
235
import 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

348
import 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
4710
import qualified Paths_purescript as Paths
48-
49-
import Utils
50-
import ErrorsWarnings
11+
import Language.PureScript.Publish (preparePackage)
5112

5213
main :: IO ()
5314
main = 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

‎purescript.cabal‎

Lines changed: 11 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -48,7 +48,11 @@ library
4848
text -any,
4949
split -any,
5050
language-javascript == 0.5.*,
51-
syb -any
51+
syb -any,
52+
Glob >= 0.7 && < 0.8,
53+
process >= 1.2.0 && < 1.3,
54+
safe >= 0.3.9 && < 0.4,
55+
semigroups >= 0.16.2 && < 0.17
5256

5357
exposed-modules: Language.PureScript
5458
Language.PureScript.AST
@@ -140,6 +144,11 @@ library
140144
Language.PureScript.Docs.ParseAndDesugar
141145
Language.PureScript.Docs.Utils.MonoidExtras
142146

147+
Language.PureScript.Publish
148+
Language.PureScript.Publish.Utils
149+
Language.PureScript.Publish.ErrorsWarnings
150+
Language.PureScript.Publish.BoxesHelpers
151+
143152
Control.Monad.Unify
144153
Control.Monad.Supply
145154
Control.Monad.Supply.Class
@@ -190,19 +199,10 @@ executable psc-docs
190199
ghc-options: -Wall -O2
191200

192201
executable psc-publish
193-
build-depends: base >=4 && <5, purescript -any,
194-
optparse-applicative >= 0.10.0, process -any, mtl -any,
195-
pattern-arrows -any, aeson -any, bytestring -any,
196-
directory -any, transformers -any, text -any, containers
197-
-any, boxes -any, split -any, Glob -any, aeson-better-errors
198-
-any, transformers-compat -any, bower-json -any, semigroups
199-
-any, safe -any
202+
build-depends: base >=4 && <5, purescript -any, bytestring -any, aeson -any, optparse-applicative -any
200203
main-is: Main.hs
201204
buildable: True
202205
hs-source-dirs: psc-publish
203-
other-modules: Utils
204-
ErrorsWarnings
205-
BoxesHelpers
206206
ghc-options: -Wall -O2
207207

208208
executable psc-hierarchy

0 commit comments

Comments
 (0)