git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Add new executable psc-publish

Adds a new program which collects all information necessary for publishing a version of a package on pursuit, and dumps it to stdout as JSON. Included changes: * expand rendered docs types (Language.PureScript.Docs.Types) * add ToJSON instances and aeson-better-errors parsers * add ToJSON/FromJSON tests for UploadedPackage * look through devDependencies as well as normal dependencies in order to decide which dependencies are undeclared * make undeclared dependencies a warning, not an error It turns out making undeclared dependencies an error can be quite annoying - for example, when trying to run psc-publish on purescript-prelude, I had purescript-eff installed and undeclared (for testing), and it was failing because of this. Arguably, this should have been an error, and I should have added purescript-eff to devDependencies. But, I didn't want to do that, because there's no suitable version of purescript-eff to use yet. There are probably other situations where it would make sense to install packages for development locally and not add them to devDependencies too, which just haven't occurred to me. Given this, I think emitting warnings is enough; I think the strategy of throwing errors would carry a much higher risk of just being annoying than actually preventing errors.

commit785324afa44f5fae53d7ec523bc1f23ce844021d authorHarry Garrood <harry@garrood.me> dateMon 13 Apr 2015, 23:52 (12 years ago) parent783061d
17 files changed+1441−43
compare with golang
unifiedsplit
.gitignore+1 psc-publish/BoxesHelpers.hs+38 psc-publish/ErrorsWarnings.hs+298 psc-publish/Main.hs+258 psc-publish/Output.hs+131 psc-publish/Utils.hs+26 psc-publish/tests/Test.hs+76 purescript.cabal+34−4 src/Language/PureScript/AST/SourcePos.hs+16−3 src/Language/PureScript/Docs.hs+1−1 src/Language/PureScript/Docs/AsHtml.hs+219 src/Language/PureScript/Docs/Render.hs+14−12 src/Language/PureScript/Docs/RenderedCode/Render.hs+2−9 src/Language/PureScript/Docs/RenderedCode/Types.hs+68−4 src/Language/PureScript/Docs/Types.hs+238−9 src/Language/PureScript/Docs/Utils/HtmlHelpers.hs+20 src/Language/PureScript/Docs/MonoidExtras.hs → src/Language/PureScript/Docs/Utils/MonoidExtras.hs+1−1
.gitignore+1
@@ -9,3 +9,4 @@ cabal.sandbox.config
99*.lksh*
1010.virthualenv
1111.psci_modules/
12+tmp/
psc-publish/BoxesHelpers.hsnew file+38
@@ -0,0 +1,38 @@
1+module BoxesHelpers
2+ ( Boxes.Box
3+ , Boxes.nullBox
4+ , module BoxesHelpers
5+ ) where
6+
7+import System.IO (hPutStr, stderr)
8+import qualified Text.PrettyPrint.Boxes as Boxes
9+
10+width :: Int
11+width = 79
12+
13+indentWidth :: Int
14+indentWidth = 2
15+
16+para :: String -> Boxes.Box
17+para = Boxes.para Boxes.left width
18+
19+indented :: Boxes.Box -> Boxes.Box
20+indented b = Boxes.hcat Boxes.left [Boxes.emptyBox 1 indentWidth, b]
21+
22+successivelyIndented :: [String] -> Boxes.Box
23+successivelyIndented [] =
24+ Boxes.nullBox
25+successivelyIndented (x:xs) =
26+ Boxes.vcat Boxes.left [para x, indented (successivelyIndented xs)]
27+
28+vcat :: [Boxes.Box] -> Boxes.Box
29+vcat = Boxes.vcat Boxes.left
30+
31+spacer :: Boxes.Box
32+spacer = Boxes.emptyBox 1 1
33+
34+bulletedList :: (a -> String) -> [a] -> [Boxes.Box]
35+bulletedList f = map (indented . para . ("* " ++) . f)
36+
37+printToStderr :: Boxes.Box -> IO ()
38+printToStderr = hPutStr stderr . Boxes.render
psc-publish/ErrorsWarnings.hsnew file+298
@@ -0,0 +1,298 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+module ErrorsWarnings where
4+
5+import Data.Aeson.BetterErrors
6+import Data.Version
7+import Data.Maybe
8+import Data.List (intersperse)
9+import Data.List.NonEmpty (NonEmpty(..))
10+import qualified Data.List.NonEmpty as NonEmpty
11+
12+import qualified Data.Text as T
13+
14+import Control.Exception (IOException)
15+import Web.Bower.PackageMeta (BowerError, PackageName, runPackageName)
16+import qualified Web.Bower.PackageMeta as Bower
17+
18+import BoxesHelpers
19+
20+-- | An error which meant that it was not possible to retrieve metadata for a
21+-- package.
22+data PackageError
23+ = UserError UserError
24+ | InternalError InternalError
25+ | OtherError OtherError
26+ deriving (Show)
27+
28+data PackageWarning
29+ = ResolutionNotVersion PackageName
30+ | UndeclaredDependency PackageName
31+ deriving (Show)
32+
33+-- | An error that should be fixed by the user.
34+data UserError
35+ = BowerJSONNotFound
36+ | CouldntParseBowerJSON (ParseError BowerError)
37+ | BowerJSONNameMissing
38+ | TagMustBeCheckedOut
39+ | AmbiguousVersions [Version] -- Invariant: should contain at least two elements
40+ | BadRepositoryField RepositoryFieldError
41+ | MissingDependencies (NonEmpty PackageName)
42+ deriving (Show)
43+
44+data RepositoryFieldError
45+ = RepositoryFieldMissing
46+ | BadRepositoryType String
47+ | NotOnGithub
48+ deriving (Show)
49+
50+-- | An error that probably indicates a bug in this module.
51+data InternalError
52+ = JSONError JSONSource (ParseError BowerError)
53+ deriving (Show)
54+
55+data JSONSource
56+ = FromFile FilePath
57+ | FromBowerList
58+ deriving (Show)
59+
60+data OtherError
61+ = ProcessFailed String [String] IOException
62+ | IOExceptionThrown IOException
63+ deriving (Show)
64+
65+printError :: PackageError -> IO ()
66+printError = printToStderr . renderError
67+
68+renderError :: PackageError -> Box
69+renderError err =
70+ case err of
71+ UserError e ->
72+ vcat
73+ [ para (concat
74+ [ "There is a problem with your package, which meant that "
75+ , "it could not be published."
76+ ])
77+ , para "Details:"
78+ , indented (displayUserError e)
79+ ]
80+ InternalError e ->
81+ vcat
82+ [ para "Internal error: this is probably a bug. Please report it:"
83+ , indented (para "https://github.com/purescript/purescript/issues/new")
84+ , spacer
85+ , para "Details:"
86+ , successivelyIndented (displayInternalError e)
87+ ]
88+ OtherError e ->
89+ vcat
90+ [ para "An error occurred, and your package could not be published."
91+ , para "Details:"
92+ , indented (displayOtherError e)
93+ ]
94+
95+displayUserError :: UserError -> Box
96+displayUserError e = case e of
97+ BowerJSONNotFound ->
98+ para (concat
99+ [ "The bower.json file was not found. Please create one, or run "
100+ , "`pulp init`."
101+ ])
102+ CouldntParseBowerJSON err ->
103+ vcat
104+ [ successivelyIndented
105+ [ "The bower.json file could not be parsed as JSON:"
106+ , "aeson reported: " ++ show err
107+ ]
108+ , para "Please ensure that your bower.json file is valid JSON."
109+ ]
110+ BowerJSONNameMissing ->
111+ vcat
112+ [ successivelyIndented
113+ [ "In bower.json:"
114+ , "the \"name\" key was not found."
115+ ]
116+ , para "Please give your package a name first."
117+ ]
118+ TagMustBeCheckedOut ->
119+ vcat
120+ [ para (concat
121+ [ "psc-publish requires a tagged version to be checked out in "
122+ , "order to build documentation, and no suitable tag was found. "
123+ , "Please check out a previously tagged version, or tag a new "
124+ , "version."
125+ ])
126+ , spacer
127+ , para "Note: tagged versions must be in one of the following forms:"
128+ , indented (para "* v{MAJOR}.{MINOR}.{PATCH} (example: \"v1.6.2\")")
129+ , indented (para "* {MAJOR}.{MINOR}.{PATCH} (example: \"1.6.2\")")
130+ ]
131+ AmbiguousVersions vs ->
132+ vcat $
133+ [ para (concat
134+ [ "The currently checked out commit seems to have been tagged with "
135+ , "more than 1 version, and I don't know which one should be used. "
136+ , "Please either delete some of the tags, or create a new commit "
137+ , "to tag the desired verson with."
138+ ])
139+ , spacer
140+ , para "Tags for the currently checked out commit:"
141+ ] ++ bulletedList showVersion vs
142+ BadRepositoryField err ->
143+ displayRepositoryError err
144+ MissingDependencies pkgs ->
145+ let singular = NonEmpty.length pkgs == 1
146+ pl a b = if singular then b else a
147+ do_ = pl "do" "does"
148+ dependencies = pl "dependencies" "dependency"
149+ them = pl "them" "it"
150+ in vcat $
151+ [ para (concat
152+ [ "The following Bower ", dependencies, " ", do_, " not appear to be "
153+ , "installed:"
154+ ])
155+ ] ++
156+ bulletedList runPackageName (NonEmpty.toList pkgs)
157+ ++
158+ [ spacer
159+ , para (concat
160+ [ "Please install ", them, " first, by running `bower install`."
161+ ])
162+ ]
163+
164+displayRepositoryError :: RepositoryFieldError -> Box
165+displayRepositoryError err = case err of
166+ RepositoryFieldMissing ->
167+ vcat
168+ [ para (concat
169+ [ "The 'repository' field is not present in your bower.json file. "
170+ , "Without this information, Pursuit would not be able to generate "
171+ , "source links in your package's documentation. Please add one - like "
172+ , "this, for example:"
173+ ])
174+ , spacer
175+ , indented (vcat
176+ [ para "\"repository\": {"
177+ , indented (para "\"type\": \"git\",")
178+ , indented (para "\"url\": \"git://github.com/purescript/purescript-prelude.git\"")
179+ , para "}"
180+ ]
181+ )
182+ ]
183+ BadRepositoryType ty ->
184+ para (concat
185+ [ "In your bower.json file, the repository type is currently listed as "
186+ , "\"" ++ ty ++ "\". Currently, only git repositories are supported. "
187+ , "Please publish your code in a git repository, and then update the "
188+ , "repository type in your bower.json file to \"git\"."
189+ ])
190+ NotOnGithub ->
191+ vcat
192+ [ para (concat
193+ [ "The repository url in your bower.json file does not point to a "
194+ , "GitHub repository. Currently, Pursuit does not support packages "
195+ , "which are not hosted on GitHub."
196+ ])
197+ , spacer
198+ , para (concat
199+ [ "Please update your bower.json file to point to a GitHub repository. "
200+ , "Alternatively, if you would prefer not to host your package on "
201+ , "GitHub, please open an issue:"
202+ ])
203+ , indented (para "https://github.com/purescript/purescript/issues/new")
204+ ]
205+
206+displayInternalError :: InternalError -> [String]
207+displayInternalError e = case e of
208+ JSONError src r ->
209+ [ "Error in JSON " ++ displayJSONSource src ++ ":"
210+ , T.unpack (Bower.displayError r)
211+ ]
212+
213+displayJSONSource :: JSONSource -> String
214+displayJSONSource s = case s of
215+ FromFile fp ->
216+ "in file " ++ show fp
217+ FromBowerList ->
218+ "in the output of `bower list --json --offline`"
219+
220+displayOtherError :: OtherError -> Box
221+displayOtherError e = case e of
222+ ProcessFailed prog args exc ->
223+ successivelyIndented
224+ [ "While running `" ++ prog ++ " " ++ unwords args ++ "`:"
225+ , show exc
226+ ]
227+ IOExceptionThrown exc ->
228+ successivelyIndented
229+ [ "An IO exception occurred:", show exc ]
230+
231+renderWarnings :: [PackageWarning] -> Box
232+renderWarnings =
233+ collectWarnings
234+ [ (getResolutionNotVersion, warnResolutionNotVersions)
235+ , (getUndeclaredDependency, warnUndeclaredDependencies)
236+ ]
237+ where
238+ collectWarnings patterns warns =
239+ let boxes = mapMaybe (collectWarnings' warns) patterns
240+ in vcat
241+ [ para "Warnings:"
242+ , indented (vcat (intersperse spacer boxes))
243+ ]
244+
245+ getResolutionNotVersion (ResolutionNotVersion n) = Just n
246+ getResolutionNotVersion _ = Nothing
247+
248+ getUndeclaredDependency (UndeclaredDependency n) = Just n
249+ getUndeclaredDependency _ = Nothing
250+
251+collectWarnings' :: [PackageWarning] -> ((PackageWarning -> Maybe a), (NonEmpty a -> Box)) -> Maybe Box
252+collectWarnings' warns (pattern, render) =
253+ case mapMaybe pattern warns of
254+ [] -> Nothing
255+ (x:xs) -> Just (render (x :| xs))
256+
257+warnResolutionNotVersions :: NonEmpty PackageName -> Box
258+warnResolutionNotVersions pkgNames =
259+ let singular = NonEmpty.length pkgNames == 1
260+ pl a b = if singular then b else a
261+
262+ packages = pl "packages" "package"
263+ were = pl "were" "was"
264+ anyOfThese = pl "any of these" "this"
265+ these = pl "these" "this"
266+ in vcat $
267+ [ para (concat
268+ ["The following ", packages, " ", were, " not resolved to a version:"])
269+ ] ++
270+ bulletedList runPackageName (NonEmpty.toList pkgNames)
271+ ++
272+ [ spacer
273+ , para (concat
274+ ["Links to types in ", anyOfThese, " ", packages, " will not work. In "
275+ , "order to make links work, edit your bower.json to specify a version"
276+ , " or a version range for ", these, " ", packages, ", and rerun "
277+ , "`bower install`."
278+ ])
279+ ]
280+
281+warnUndeclaredDependencies :: NonEmpty PackageName -> Box
282+warnUndeclaredDependencies pkgNames =
283+ let singular = NonEmpty.length pkgNames == 1
284+ pl a b = if singular then b else a
285+
286+ packages = pl "packages" "package"
287+ are = pl "are" "is"
288+ dependencies = pl "dependencies" "a dependency"
289+ in vcat $
290+ [ para (concat
291+ [ "The following Bower ", packages, " ", are, " installed, but not "
292+ , "declared as ", dependencies, " in your bower.json file:"
293+ ])
294+ ] ++
295+ bulletedList runPackageName (NonEmpty.toList pkgNames)
296+
297+printWarnings :: [PackageWarning] -> IO ()
298+printWarnings = printToStderr . renderWarnings
psc-publish/Main.hsnew file+258
@@ -0,0 +1,258 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE RecordWildCards #-}
3+{-# LANGUAGE TupleSections #-}
4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5+
6+import Prelude hiding (userError)
7+
8+import Data.Maybe
9+import Data.Char (isSpace)
10+import Data.String (fromString)
11+import Data.List (stripPrefix, isSuffixOf, (\\))
12+import Data.List.Split (splitOn)
13+import Data.List.NonEmpty (NonEmpty(..))
14+import Data.Version
15+
16+import qualified Data.ByteString.Lazy.Char8 as BL
17+import qualified Data.Text as T
18+
19+import qualified Data.Aeson as A
20+import Data.Aeson.BetterErrors
21+
22+import Control.Applicative
23+import Control.Category ((>>>))
24+import Control.Arrow ((***))
25+import Control.Exception (catch, try)
26+import Control.Monad.Trans.Except
27+import Control.Monad.Error.Class (MonadError(..))
28+import Control.Monad.Writer
29+
30+import System.Directory (doesFileExist)
31+import System.Process (readProcess)
32+import System.Exit (exitFailure)
33+import qualified System.FilePath.Glob as Glob
34+
35+import Web.Bower.PackageMeta (PackageMeta(..), BowerError(..), PackageName,
36+ runPackageName, parsePackageName, Repository(..))
37+import qualified Web.Bower.PackageMeta as Bower
38+
39+import qualified Language.PureScript.Docs as D
40+import Output (parseAndDesugar, getInputAndDepsFiles)
41+import Utils
42+import ErrorsWarnings
43+
44+main :: IO ()
45+main = do
46+ pkg <- preparePackage
47+ BL.putStrLn (A.encode pkg)
48+
49+-- | Attempt to retrieve package metadata from the current directory.
50+-- Calls exitFailure if no package metadata could be retrieved.
51+preparePackage :: IO D.UploadedPackage
52+preparePackage =
53+ runPrepareM preparePackage'
54+ >>= either (\e -> printError e >> exitFailure)
55+ handleWarnings
56+ where
57+ handleWarnings (result, warns) = do
58+ printWarnings warns
59+ return result
60+
61+newtype PrepareM a =
62+ PrepareM { unPrepareM :: WriterT [PackageWarning] (ExceptT PackageError IO) a }
63+ deriving (Functor, Applicative, Monad,
64+ MonadWriter [PackageWarning],
65+ MonadError PackageError)
66+
67+-- This MonadIO instance ensures that IO errors don't crash the program.
68+instance MonadIO PrepareM where
69+ liftIO act =
70+ lift' (try act) >>= either (otherError . IOExceptionThrown) return
71+ where
72+ lift' :: IO a -> PrepareM a
73+ lift' = PrepareM . lift . lift
74+
75+runPrepareM :: PrepareM a -> IO (Either PackageError (a, [PackageWarning]))
76+runPrepareM = runExceptT . runWriterT . unPrepareM
77+
78+warn :: PackageWarning -> PrepareM ()
79+warn w = tell [w]
80+
81+userError :: UserError -> PrepareM a
82+userError = throwError . UserError
83+
84+internalError :: InternalError -> PrepareM a
85+internalError = throwError . InternalError
86+
87+otherError :: OtherError -> PrepareM a
88+otherError = throwError . OtherError
89+
90+catchLeft :: Applicative f => Either a b -> (a -> f b) -> f b
91+catchLeft a f = either f pure a
92+
93+preparePackage' :: PrepareM D.UploadedPackage
94+preparePackage' = do
95+ exists <- liftIO (doesFileExist "bower.json")
96+ unless exists (userError BowerJSONNotFound)
97+
98+ pkgMeta <- liftIO (Bower.decodeFile "bower.json")
99+ >>= flip catchLeft (userError . CouldntParseBowerJSON)
100+ pkgVersion <- getVersionFromGitTag
101+ pkgGithub <- getBowerInfo pkgMeta
102+ (pkgBookmarks, pkgModules) <- liftIO getModulesAndBookmarks
103+
104+ let declaredDeps = map fst (bowerDependencies pkgMeta ++ bowerDevDependencies pkgMeta)
105+ pkgResolvedDependencies <- getResolvedDependencies declaredDeps
106+
107+ let pkgUploader = Nothing
108+
109+ return D.UploadedPackage{..}
110+
111+getModulesAndBookmarks :: IO ([D.Bookmark], [D.RenderedModule])
112+getModulesAndBookmarks = do
113+ (inputFiles, depsFiles) <- getInputAndDepsFiles
114+ parseAndDesugar inputFiles depsFiles $ \bookmarks modules ->
115+ return (bookmarks, map D.renderModule modules)
116+
117+getVersionFromGitTag :: PrepareM Version
118+getVersionFromGitTag = do
119+ out <- readProcess' "git" ["tag", "--list", "--points-at", "HEAD"] ""
120+ let vs = map clean (lines out)
121+ case mapMaybe D.parseVersion' vs of
122+ [] -> userError TagMustBeCheckedOut
123+ [x] -> return x
124+ xs -> userError (AmbiguousVersions xs)
125+ where
126+ clean =
127+ trimWhitespace >>> dropPrefix "v"
128+ trimWhitespace =
129+ dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse
130+ dropPrefix prefix str =
131+ fromMaybe str (stripPrefix prefix str)
132+
133+getBowerInfo :: PackageMeta -> PrepareM (D.GithubUser, D.GithubRepo)
134+getBowerInfo = either (userError . BadRepositoryField) return . tryExtract
135+ where
136+ tryExtract pkgMeta =
137+ case bowerRepository pkgMeta of
138+ Nothing -> Left RepositoryFieldMissing
139+ Just Repository{..} -> do
140+ unless (repositoryType == "git")
141+ (Left (BadRepositoryType repositoryType))
142+ maybe (Left NotOnGithub) Right (extractGithub repositoryUrl)
143+
144+extractGithub :: String -> Maybe (D.GithubUser, D.GithubRepo)
145+extractGithub =
146+ stripPrefix "git://github.com/"
147+ >>> fmap (splitOn "/")
148+ >=> takeTwo
149+ >>> fmap (D.GithubUser *** (D.GithubRepo . dropDotGit))
150+
151+ where
152+ takeTwo :: [a] -> Maybe (a, a)
153+ takeTwo [x, y] = Just (x, y)
154+ takeTwo _ = Nothing
155+
156+ dropDotGit :: String -> String
157+ dropDotGit str
158+ | ".git" `isSuffixOf` str = take (length str - 4) str
159+ | otherwise = str
160+
161+readProcess' :: String -> [String] -> String -> PrepareM String
162+readProcess' prog args stdin = do
163+ out <- liftIO (catch (Right <$> readProcess prog args stdin)
164+ (return . Left))
165+ either (otherError . ProcessFailed prog args) return out
166+
167+data DependencyStatus
168+ = Missing
169+ | ResolvedOther String
170+ -- ^ Resolved, but to something other than a version. The String argument
171+ -- is the resolution type. The values it can take that I'm aware of are
172+ -- "commit" and "branch".
173+ | ResolvedVersion String
174+ -- ^ Resolved to a version. The String argument is the resolution tag (eg,
175+ -- "v0.1.0").
176+ deriving (Show, Eq)
177+
178+-- Go through all bower dependencies which contain purescript code, and
179+-- extract their versions.
180+--
181+-- In the case where a bower dependency is taken from a particular version,
182+-- that's easy; take that version. In any other case (eg, a branch, or a commit
183+-- sha) we print a warning that documentation links will not work, and avoid
184+-- linking to documentation for any types from that package.
185+--
186+-- The rationale for this is: people will prefer to use a released version
187+-- where possible. If they are not using a released version, then this is
188+-- probably for a reason. However, docs are only ever available for released
189+-- versions. Therefore there will probably be no version of the docs which is
190+-- appropriate to link to, and we should omit links.
191+getResolvedDependencies :: [PackageName] -> PrepareM [(PackageName, Version)]
192+getResolvedDependencies declaredDeps = do
193+ depsBS <- fromString <$> readProcess' "bower" ["list", "--json", "--offline"] ""
194+
195+ deps <- catchLeft (parse asBowerResolvedDependencies depsBS)
196+ (internalError . JSONError FromBowerList)
197+
198+ warnUndeclared declaredDeps (map fst deps)
199+ handleDeps deps
200+
201+ where
202+ asBowerResolvedDependencies ::
203+ Parse BowerError [(PackageName, DependencyStatus)]
204+ asBowerResolvedDependencies =
205+ key "dependencies"
206+ (eachInObjectWithKey (parsePackageName . T.unpack) asDependencyStatus)
207+
208+asDependencyStatus :: Parse e DependencyStatus
209+asDependencyStatus = do
210+ isMissing <- keyOrDefault "missing" False asBool
211+ if isMissing
212+ then
213+ return Missing
214+ else
215+ key "pkgMeta" $
216+ key "_resolution" $ do
217+ type_ <- key "type" asString
218+ case type_ of
219+ "version" -> ResolvedVersion <$> key "tag" asString
220+ other -> return (ResolvedOther other)
221+
222+warnUndeclared :: [PackageName] -> [PackageName] -> PrepareM ()
223+warnUndeclared declared actual =
224+ mapM_ (warn . UndeclaredDependency) (actual \\ declared)
225+
226+handleDeps ::
227+ [(PackageName, DependencyStatus)] -> PrepareM [(PackageName, Version)]
228+handleDeps deps = do
229+ let (missing, notVersion, installed) = partitionDeps deps
230+ case missing of
231+ (x:xs) ->
232+ userError (MissingDependencies (x :| xs))
233+ [] -> do
234+ mapM_ (warn . ResolutionNotVersion . fst) notVersion
235+ let withVersions = mapMaybe tryExtractVersion installed
236+ filterM (liftIO . isPureScript . bowerDir . fst) withVersions
237+
238+ where
239+ partitionDeps = foldr go ([], [], [])
240+ go (pkgName, d) (ms, os, is) =
241+ case d of
242+ Missing -> (pkgName : ms, os, is)
243+ ResolvedOther o -> (ms, (pkgName, o) : os, is)
244+ ResolvedVersion v -> (ms, os, (pkgName, v) : is)
245+
246+ bowerDir pkgName = "bower_components/" ++ runPackageName pkgName
247+
248+tryExtractVersion :: (PackageName, String) -> Maybe (PackageName, Version)
249+tryExtractVersion (pkgName, tag) =
250+ let tag' = fromMaybe tag (stripPrefix "v" tag)
251+ in (pkgName,) <$> D.parseVersion' tag'
252+
253+-- | Returns whether it looks like there is a purescript package checked out
254+-- in the given directory.
255+isPureScript :: FilePath -> IO Bool
256+isPureScript dir = do
257+ files <- Glob.globDir1 purescriptSourceFiles dir
258+ return (not (null files))
psc-publish/Output.hsnew file+131
@@ -0,0 +1,131 @@
1+{-# LANGUAGE TupleSections #-}
2+
3+-- | Functions and types relevant to producing some form of output after
4+-- rendering documentation.
5+
6+module Output where
7+
8+import qualified Data.Map as M
9+import Data.Maybe (mapMaybe)
10+import Data.List.Split (splitOn)
11+import Data.List (stripPrefix)
12+
13+import Control.Applicative
14+import Control.Monad
15+import Control.Arrow (first)
16+
17+import qualified Language.PureScript as P
18+import qualified Language.PureScript.Constants as C
19+
20+import System.Exit (exitFailure)
21+import System.IO (hPutStrLn, stderr)
22+
23+import Language.PureScript.Docs
24+import Web.Bower.PackageMeta hiding (Version)
25+
26+import Utils
27+
28+-- | Specifies whether a PureScript source file is considered as:
29+--
30+-- 1) with the `Local` constructor, a target source file, i.e., we want to see
31+-- its modules in the output
32+-- 2) with the `FromDep` constructor, a dependencies source file, i.e. we do
33+-- not want its modules in the output; it is there to enable desugaring, and
34+-- to ensure that links between modules are constructed correctly.
35+type FileInfo = InPackage FilePath
36+
37+fileInfoToString :: FileInfo -> FilePath
38+fileInfoToString (Local fn) = fn
39+fileInfoToString (FromDep _ fn) = fn
40+
41+addDefaultImport :: P.ModuleName -> P.Module -> P.Module
42+addDefaultImport toImport m@(P.Module coms mn decls exps) =
43+ if isExistingImport `any` decls || mn == toImport then m
44+ else P.Module coms mn (P.ImportDeclaration toImport P.Implicit Nothing : decls) exps
45+ where
46+ isExistingImport (P.ImportDeclaration mn' _ _) | mn' == toImport = True
47+ isExistingImport (P.PositionedDeclaration _ _ d) = isExistingImport d
48+ isExistingImport _ = False
49+
50+importPrim :: P.Module -> P.Module
51+importPrim = addDefaultImport (P.ModuleName [P.ProperName C.prim])
52+
53+importPrelude :: P.Module -> P.Module
54+importPrelude = addDefaultImport (P.ModuleName [P.ProperName C.prelude])
55+
56+desugar :: [P.Module] -> Either P.MultipleErrors [P.Module]
57+desugar = P.evalSupplyT 0 . desugar'
58+ where
59+ desugar' :: [P.Module] -> P.SupplyT (Either P.MultipleErrors) [P.Module]
60+ desugar' = mapM P.desugarDoModule >=> P.desugarCasesModule >=> P.desugarImports
61+
62+parseFile :: FilePath -> IO (FilePath, String)
63+parseFile input' = (,) input' <$> readFile input'
64+
65+parseAndDesugar ::
66+ [FilePath]
67+ -> [(PackageName, FilePath)]
68+ -> ([Bookmark] -> [P.Module] -> IO a)
69+ -> IO a
70+parseAndDesugar inputFiles depsFiles callback = do
71+ inputFiles' <- mapM (parseAs Local) inputFiles
72+ depsFiles' <- mapM (\(pkgName, f) -> parseAs (FromDep pkgName) f) depsFiles
73+
74+ case P.parseModulesFromFiles fileInfoToString (inputFiles' ++ depsFiles') of
75+ Left err -> do
76+ hPutStrLn stderr "parse failed:"
77+ hPutStrLn stderr $ show err
78+ exitFailure
79+ Right ms -> do
80+ let depsModules = getDepsModuleNames (map (\(fp, m) -> (,m) <$> fp) ms)
81+ case P.sortModules . map (importPrim . importPrelude . snd) $ ms of
82+ Left e' -> do
83+ hPutStrLn stderr "sortModules failed:"
84+ hPutStrLn stderr (P.prettyPrintMultipleErrors False e')
85+ exitFailure
86+ Right (ms', _) ->
87+ case desugar ms' of
88+ Left err -> do
89+ hPutStrLn stderr "desugar failed:"
90+ hPutStrLn stderr (P.prettyPrintMultipleErrors False err)
91+ exitFailure
92+ Right modules ->
93+ let modules' = map (addPackage depsModules) modules
94+ bookmarks = concatMap collectBookmarks modules'
95+ in callback bookmarks (takeLocals modules')
96+
97+ where
98+ parseAs :: (FilePath -> a) -> FilePath -> IO (a, String)
99+ parseAs g = fmap (first g) . parseFile
100+
101+ getDepsModuleNames :: [InPackage (FilePath, P.Module)] -> M.Map P.ModuleName PackageName
102+ getDepsModuleNames = foldl go M.empty
103+ where
104+ go deps p = deps # case p of
105+ Local _ -> id
106+ FromDep pkgName (_, m) -> M.insert (P.getModuleName m) pkgName
107+ (#) = flip ($)
108+
109+ addPackage :: M.Map P.ModuleName PackageName -> P.Module -> InPackage P.Module
110+ addPackage depsModules m =
111+ case M.lookup (P.getModuleName m) depsModules of
112+ Just pkgName -> FromDep pkgName m
113+ Nothing -> Local m
114+
115+getInputAndDepsFiles :: IO ([FilePath], [(PackageName, FilePath)])
116+getInputAndDepsFiles = do
117+ inputFiles <- globRelative purescriptSourceFiles
118+ depsFiles' <- globRelative purescriptDepsFiles
119+ return (inputFiles, mapMaybe withPackageName depsFiles')
120+
121+withPackageName :: FilePath -> Maybe (PackageName, FilePath)
122+withPackageName fp = (,fp) <$> getPackageName fp
123+
124+getPackageName :: FilePath -> Maybe PackageName
125+getPackageName fp = do
126+ let xs = splitOn "/" fp
127+ ys <- stripPrefix ["bower_components"] xs
128+ y <- headMay ys
129+ case mkPackageName y of
130+ Right name -> Just name
131+ Left _ -> Nothing
psc-publish/Utils.hsnew file+26
@@ -0,0 +1,26 @@
1+
2+module Utils where
3+
4+import Data.List
5+import Data.Maybe
6+import System.Directory
7+import qualified System.FilePath.Glob as Glob
8+
9+headMay :: [a] -> Maybe a
10+headMay (x:_) = Just x
11+headMay [] = Nothing
12+
13+-- | Glob relative to the current directory, and produce relative pathnames.
14+globRelative :: Glob.Pattern -> IO [FilePath]
15+globRelative pat = do
16+ currentDir <- getCurrentDirectory
17+ filesAbsolute <- Glob.globDir1 pat currentDir
18+ return (mapMaybe (stripPrefix (currentDir ++ "/")) filesAbsolute)
19+
20+-- | Glob pattern for PureScript source files.
21+purescriptSourceFiles :: Glob.Pattern
22+purescriptSourceFiles = Glob.compile "src/**/*.purs"
23+
24+-- | Glob pattern for PureScript dependency files.
25+purescriptDepsFiles :: Glob.Pattern
26+purescriptDepsFiles = Glob.compile "bower_components/*/src/**/*.purs"
psc-publish/tests/Test.hsnew file+76
@@ -0,0 +1,76 @@
1+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
2+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
3+
4+-- | To run these tests:
5+--
6+-- * `cabal repl psc-publish`
7+-- * `:l psc-publish/tests/Test.hs`
8+-- * `test`
9+
10+module Test where
11+
12+import Control.Monad
13+import Control.Applicative
14+import System.Process
15+import System.Directory
16+import qualified Data.ByteString.Lazy as BL
17+import Data.ByteString.Lazy (ByteString)
18+import qualified Data.Aeson as A
19+import Data.Aeson.BetterErrors
20+
21+import Main
22+import Language.PureScript.Docs
23+
24+packageName = "purescript-integers"
25+packageUrl = "https://github.com/purescript/" ++ packageName
26+packageDir = "tmp/" ++ packageName
27+
28+pushd :: FilePath -> IO a -> IO a
29+pushd dir act = do
30+ original <- getCurrentDirectory
31+ setCurrentDirectory dir
32+ result <- act
33+ setCurrentDirectory original
34+ return result
35+
36+clonePackage :: IO ()
37+clonePackage = do
38+ createDirectoryIfMissing True packageDir
39+ pushd packageDir $ do
40+ exists <- doesDirectoryExist ".git"
41+ unless exists $ do
42+ putStrLn ("Cloning " ++ packageName ++ " into " ++ packageDir ++ "...")
43+ readProcess "git" ["clone", packageUrl, "."] "" >>= putStr
44+
45+bowerInstall :: IO ()
46+bowerInstall = do
47+ pushd packageDir $ do
48+ readProcess "bower" ["install"] "" >>= putStr
49+
50+getPackage :: IO UploadedPackage
51+getPackage = do
52+ clonePackage
53+ bowerInstall
54+ pushd packageDir preparePackage
55+
56+data TestResult
57+ = ParseFailed (ParseError UploadedPackageError)
58+ | Mismatch ByteString ByteString -- ^ encoding before, encoding after
59+ | Pass ByteString
60+ deriving (Show)
61+
62+-- | Test JSON encoding/decoding; parse the package, roundtrip to/from JSON,
63+-- and check we get the same string.
64+test :: IO TestResult
65+test = roundTrip <$> getPackage
66+
67+roundTrip :: UploadedPackage -> TestResult
68+roundTrip pkg =
69+ let before = A.encode pkg
70+ in case parse asUploadedPackage before of
71+ Left err -> ParseFailed err
72+ Right parsed -> do
73+ let after = A.encode parsed
74+ if before == after
75+ then Pass before
76+ else Mismatch before after
purescript.cabal+34−4
@@ -26,6 +26,7 @@ library
2626 build-depends: base >=4.6 && <5,
2727 containers -any,
2828 unordered-containers -any,
29+ dlist -any,
2930 directory >= 1.2,
3031 filepath -any,
3132 mtl >= 2.1.0 && < 2.3.0,
@@ -35,7 +36,18 @@ library
3536 utf8-string >= 1 && < 2,
3637 pattern-arrows >= 0.0.2 && < 0.1,
3738 time -any,
38− boxes >= 0.1.4 && < 0.2.0
39+ boxes >= 0.1.4 && < 0.2.0,
40+ aeson >= 0.8 && < 0.9,
41+ vector -any,
42+ bower-json >= 0.7,
43+ aeson-better-errors >= 0.5,
44+ bytestring -any,
45+ text -any,
46+ split -any,
47+ lucid -any,
48+ blaze-html -any,
49+ data-default -any,
50+ cheapskate -any
3951 exposed-modules: Language.PureScript
4052 Language.PureScript.AST
4153 Language.PureScript.AST.Binders
@@ -118,8 +130,10 @@ library
118130 Language.PureScript.Docs.RenderedCode
119131 Language.PureScript.Docs.RenderedCode.Types
120132 Language.PureScript.Docs.RenderedCode.Render
121− Language.PureScript.Docs.MonoidExtras
122133 Language.PureScript.Docs.AsMarkdown
134+ Language.PureScript.Docs.AsHtml
135+ Language.PureScript.Docs.Utils.HtmlHelpers
136+ Language.PureScript.Docs.Utils.MonoidExtras
123137
124138 Control.Monad.Unify
125139 Control.Monad.Supply
@@ -169,8 +183,7 @@ executable psci
169183
170184executable psc-docs
171185 build-depends: base >=4 && <5, purescript -any,
172− optparse-applicative >= 0.10.0, process -any, mtl -any,
173− pattern-arrows -any
186+ optparse-applicative >= 0.10.0, process -any, mtl -any
174187 main-is: Main.hs
175188 buildable: True
176189 hs-source-dirs: psc-docs
@@ -179,6 +192,23 @@ executable psc-docs
179192 Tags
180193 ghc-options: -Wall -O2
181194
195+executable psc-publish
196+ build-depends: base >=4 && <5, purescript -any,
197+ optparse-applicative >= 0.10.0, process -any, mtl -any,
198+ pattern-arrows -any, aeson -any, bytestring -any,
199+ directory -any, transformers -any, text -any, containers
200+ -any, boxes -any, split -any, Glob -any, aeson-better-errors
201+ -any, transformers-compat -any, bower-json -any, semigroups
202+ -any
203+ main-is: Main.hs
204+ buildable: True
205+ hs-source-dirs: psc-publish
206+ other-modules: Output
207+ Utils
208+ ErrorsWarnings
209+ BoxesHelpers
210+ ghc-options: -Wall -O2
211+
182212executable psc-hierarchy
183213 build-depends: base >=4 && <5, purescript -any, optparse-applicative >= 0.10.0,
184214 process -any, mtl -any, parsec -any, filepath -any, directory -any
src/Language/PureScript/AST/SourcePos.hs+16−3
@@ -12,11 +12,13 @@
1212--
1313-----------------------------------------------------------------------------
1414
15−{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}
15+{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, RecordWildCards, OverloadedStrings #-}
1616
1717module Language.PureScript.AST.SourcePos where
1818
1919import qualified Data.Data as D
20+import Data.Aeson ((.=))
21+import qualified Data.Aeson as A
2022
2123-- |
2224-- Source position information
@@ -30,13 +32,17 @@ data SourcePos = SourcePos
3032 -- Column number
3133 --
3234 , sourcePosColumn :: Int
33− } deriving (Eq, Show, D.Data, D.Typeable)
35+ } deriving (Eq, Ord, Show, D.Data, D.Typeable)
3436
3537displaySourcePos :: SourcePos -> String
3638displaySourcePos sp =
3739 "line " ++ show (sourcePosLine sp) ++
3840 ", column " ++ show (sourcePosColumn sp)
3941
42+instance A.ToJSON SourcePos where
43+ toJSON SourcePos{..} =
44+ A.toJSON [sourcePosLine, sourcePosColumn]
45+
4046data SourceSpan = SourceSpan
4147 { -- |
4248 -- Source name
@@ -49,10 +55,17 @@ data SourceSpan = SourceSpan
4955 -- End of the span
5056 --
5157 , spanEnd :: SourcePos
52− } deriving (Eq, Show, D.Data, D.Typeable)
58+ } deriving (Eq, Ord, Show, D.Data, D.Typeable)
5359
5460displaySourceSpan :: SourceSpan -> String
5561displaySourceSpan sp =
5662 spanName sp ++ " " ++
5763 displaySourcePos (spanStart sp) ++ " - " ++
5864 displaySourcePos (spanEnd sp)
65+
66+instance A.ToJSON SourceSpan where
67+ toJSON SourceSpan{..} =
68+ A.object [ "name" .= spanName
69+ , "start" .= spanStart
70+ , "end" .= spanEnd
71+ ]
src/Language/PureScript/Docs.hs+1−1
@@ -9,4 +9,4 @@ module Language.PureScript.Docs (
99import Language.PureScript.Docs.Types as Docs
1010import Language.PureScript.Docs.RenderedCode.Types as Docs
1111import Language.PureScript.Docs.RenderedCode.Render as Docs
12−
12+import Language.PureScript.Docs.Render as Docs
src/Language/PureScript/Docs/AsHtml.hsnew file+219
@@ -0,0 +1,219 @@
1+{-# LANGUAGE RecordWildCards #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE TemplateHaskell #-}
4+{-# LANGUAGE ViewPatterns #-}
5+
6+-- | Functions for rendering generated documentation from PureScript code as
7+-- HTML.
8+
9+module Language.PureScript.Docs.AsHtml (
10+ HtmlOutput(..),
11+ packageAsHtml
12+) where
13+
14+import Control.Arrow (second)
15+import Control.Category ((>>>))
16+import Data.Char (toUpper)
17+import Data.Ord (comparing)
18+import Data.Monoid (mconcat)
19+import Data.Foldable (for_)
20+import Data.List (intercalate, find, sortBy)
21+import qualified Data.DList as DList
22+import Data.List.Split (splitOn)
23+import Data.Default (def)
24+import Data.Version
25+import qualified Data.Map as M
26+
27+import qualified Data.Text as T
28+
29+import Lucid hiding (for_)
30+import qualified Text.Blaze.Html as H
31+import qualified Text.Blaze.Html.Renderer.Text as H
32+import qualified Cheapskate
33+
34+import System.FilePath ((</>))
35+
36+import Web.Bower.PackageMeta hiding (Version)
37+
38+import qualified Language.PureScript as P
39+
40+import Language.PureScript.Docs.Types
41+import Language.PureScript.Docs.RenderedCode hiding (sp)
42+import Language.PureScript.Docs.Utils.HtmlHelpers
43+
44+data LinksContext = LinksContext
45+ { ctxGithub :: (GithubUser, GithubRepo)
46+ , ctxBookmarks :: [Bookmark]
47+ , ctxResolvedDependencies :: [(PackageName, Version)]
48+ }
49+ deriving (Show, Eq, Ord)
50+
51+-- | A LinksContext with the current module name.
52+type LinksContext' = (LinksContext, P.ModuleName)
53+
54+data DocLink
55+ -- | A link to a declaration in the same module; in this case, only the title
56+ -- is needed to generate the link.
57+ = SameModule String
58+
59+ -- | A link to a declaration in a different module, but still in the current
60+ -- package; we need to store the current module, the other declaration's
61+ -- module, and the declaration title.
62+ | LocalModule P.ModuleName P.ModuleName String
63+
64+ -- | A link to a declaration in a different package. We store: current module
65+ -- name, name of the other package, version of the other package, name of
66+ -- the module in the other package that the declaration is in, and
67+ -- declaration title.
68+ | DepsModule P.ModuleName PackageName Version P.ModuleName String
69+ deriving (Show, Eq, Ord)
70+
71+data HtmlOutput = HtmlOutput
72+ { htmlIndex :: [(Maybe Char, Html ())]
73+ , htmlModules :: [(P.ModuleName, Html ())]
74+ }
75+ deriving (Show)
76+
77+packageAsHtml :: UploadedPackage -> HtmlOutput
78+packageAsHtml UploadedPackage{..} = HtmlOutput indexFile modules
79+ where
80+ indexFile = renderIndex ctx
81+ modules = map (moduleAsHtml ctx) pkgModules
82+ ctx = LinksContext pkgGithub pkgBookmarks pkgResolvedDependencies
83+
84+moduleAsHtml :: LinksContext -> RenderedModule -> (P.ModuleName, Html ())
85+moduleAsHtml ctx RenderedModule{..} = (mn, html)
86+ where
87+ mn = P.moduleNameFromString rmName
88+ ctx' = (ctx, mn)
89+ html = do
90+ h1_ $ do
91+ text "module "
92+ strong_ (text rmName)
93+ for_ rmComments renderComments
94+ for_ rmDeclarations (declAsHtml ctx')
95+
96+renderIndex :: LinksContext -> [(Maybe Char, Html ())]
97+renderIndex LinksContext{..} = go ctxBookmarks
98+ where
99+ go = takeLocals
100+ >>> groupIndex getIndex renderEntry
101+ >>> map (second (ul_ . mconcat))
102+
103+ getIndex (_, ((toUpper -> c) :_))
104+ | c `elem` ['A'..'Z'] = Just c
105+ | otherwise = Nothing
106+ getIndex _ = Nothing
107+
108+ renderEntry (mn, title) =
109+ li_ $ do
110+ let url = T.pack ((filePathFor mn `relativeTo` "index") ++ "#" ++ title)
111+ code_ (a_ [href_ url] (text title))
112+ sp
113+ text ("(" ++ show mn ++ ")")
114+
115+ groupIndex :: Ord i => (a -> Maybe i) -> (a -> b) -> [a] -> [(Maybe i, [b])]
116+ groupIndex f g =
117+ map (second DList.toList) . M.toList . foldr go' M.empty . sortBy (comparing f)
118+ where
119+ go' x = insertOrAppend (f x) (g x)
120+ insertOrAppend idx val m =
121+ let cur = M.findWithDefault DList.empty idx m
122+ new = DList.snoc cur val
123+ in M.insert idx new m
124+
125+declAsHtml :: LinksContext' -> RenderedDeclaration -> Html ()
126+declAsHtml ctx RenderedDeclaration{..} = do
127+ a_ [name_ (T.pack rdTitle), href_ (T.pack ('#' : rdTitle))] $
128+ h2_ (code_ (text rdTitle))
129+ para "decl" (code_ (codeAsHtml ctx rdCode))
130+ renderChildren ctx rdChildren
131+ case rdComments of
132+ Just cs -> renderComments cs
133+ Nothing -> return ()
134+ for_ rdSourceSpan (linkToSource ctx)
135+
136+renderChildren :: LinksContext' -> [RenderedChildDeclaration] -> Html ()
137+renderChildren _ [] = return ()
138+renderChildren ctx xs = go xs
139+ where
140+ go = ul_ . mapM_ (li_ . code_ . codeAsHtml ctx . rcdCode)
141+
142+codeAsHtml :: LinksContext' -> RenderedCode -> Html ()
143+codeAsHtml ctx = outputWith elemAsHtml
144+ where
145+ elemAsHtml (Syntax x) = withClass "syntax" (text x)
146+ elemAsHtml (Ident x) = withClass "ident" (text x)
147+ elemAsHtml (Ctor x mn) = linkToConstructor ctx x mn (withClass "ctor" (text x))
148+ elemAsHtml (Kind x) = text x
149+ elemAsHtml (Keyword x) = withClass "keyword" (text x)
150+ elemAsHtml Space = text " "
151+
152+getLink :: LinksContext' -> String -> ContainingModule -> Maybe DocLink
153+getLink (LinksContext{..}, curMn) ctor' containingMod = do
154+ let bookmark' = (fromContainingModule curMn containingMod, ctor')
155+ bookmark <- find ((bookmark' ==) . ignorePackage) ctxBookmarks
156+
157+ case containingMod of
158+ ThisModule -> return (SameModule ctor')
159+ OtherModule destMn ->
160+ case bookmark of
161+ Local _ -> return (LocalModule curMn destMn ctor')
162+ FromDep pkgName _ -> do
163+ pkgVersion <- lookup pkgName ctxResolvedDependencies
164+ return (DepsModule curMn pkgName pkgVersion destMn ctor')
165+
166+renderLink :: DocLink -> Html () -> Html ()
167+renderLink (SameModule x) = linkTo ('#' : x)
168+renderLink (LocalModule srcMn destMn x) =
169+ let uri = filePathFor destMn `relativeTo` filePathFor srcMn
170+ in linkTo (uri ++ "#" ++ x)
171+renderLink (DepsModule srcMn pkgName pkgVersion destMn x) =
172+ let relativeTo' = relativeToOtherPackage pkgName pkgVersion
173+ uri = filePathFor destMn `relativeTo'` filePathFor srcMn
174+ in linkTo (uri ++ "#" ++ x)
175+
176+linkToConstructor :: LinksContext' -> String -> ContainingModule -> Html () -> Html ()
177+linkToConstructor ctx ctor' containMn =
178+ maybe id renderLink (getLink ctx ctor' containMn)
179+
180+linkToSource :: LinksContext' -> P.SourceSpan -> Html ()
181+linkToSource (LinksContext{..}, _) (P.SourceSpan name start end) =
182+ linkTo (concat
183+ [githubBaseUrl, "/tree/master/", relativeToBase name, "#", fragment])
184+ (text "Source")
185+ where
186+ (P.SourcePos startLine _) = start
187+ (P.SourcePos endLine _) = end
188+ (GithubUser user, GithubRepo repo) = ctxGithub
189+
190+ relativeToBase = intercalate "/" . dropWhile (/= "src") . splitOn "/"
191+ githubBaseUrl = concat ["https://github.com/", user, "/", repo]
192+ fragment = "L" ++ show startLine ++ "-L" ++ show endLine
193+
194+-- TODO: use GitHub API instead?
195+renderComments :: String -> Html ()
196+renderComments = toHtml . H.renderHtml . H.toHtml . Cheapskate.markdown def . T.pack
197+
198+-- | if `to` and `from` are both files in the current package, generate a
199+-- FilePath for `to` relative to `from`.
200+relativeTo :: FilePath -> FilePath -> FilePath
201+relativeTo to from = go (splitOn "/" to) (splitOn "/" from)
202+ where
203+ go (x : xs) (y : ys) | x == y = go xs ys
204+ go xs ys = intercalate "/" $ replicate (length ys - 1) ".." ++ xs
205+
206+-- | Generate a FilePath for module documentation for a module in the current
207+-- package.
208+filePathFor :: P.ModuleName -> FilePath
209+filePathFor (P.ModuleName parts) = go parts
210+ where
211+ go [] = "index.html"
212+ go (x : xs) = show x </> go xs
213+
214+-- | Like `relativeTo`, but in the case where `to` is in another package.
215+relativeToOtherPackage :: PackageName -> Version -> FilePath -> FilePath -> FilePath
216+relativeToOtherPackage name (showVersion -> vers) to from =
217+ intercalate "/" (dots ++ [runPackageName name, vers] ++ splitOn "/" to)
218+ where
219+ dots = replicate (length from - 1) ".."
src/Language/PureScript/Docs/Render.hs+14−12
@@ -6,30 +6,21 @@
66-- | Functions for rendering documentation generated from PureScript code.
77
88module Language.PureScript.Docs.Render (
9− renderPackage,
10− renderModule
9+ renderModule,
10+ collectBookmarks
1111) where
1212
1313import Control.Monad
1414import Data.Either
15−import Data.Version (Version)
1615import Data.Monoid ((<>))
1716import Data.Maybe (mapMaybe)
1817import Data.List (nub)
1918
2019import qualified Language.PureScript as P
2120
22−import Language.PureScript.Docs.MonoidExtras
2321import Language.PureScript.Docs.RenderedCode
2422import Language.PureScript.Docs.Types
25−
26−-- |
27−-- Render a Package, given its name, its current version, and a list of
28−-- contained modules.
29−--
30−renderPackage :: String -> Version -> [P.Module] -> RenderedPackage
31−renderPackage name vers mods =
32− RenderedPackage name vers (map renderModule mods)
23+import Language.PureScript.Docs.Utils.MonoidExtras
3324
3425-- |
3526-- Render a single Module.
@@ -235,3 +226,14 @@ renderComments cs = do
235226toTypeVar :: (String, Maybe P.Kind) -> P.Type
236227toTypeVar (s, Nothing) = P.TypeVar s
237228toTypeVar (s, Just k) = P.KindedType (P.TypeVar s) k
229+
230+collectBookmarks :: InPackage P.Module -> [Bookmark]
231+collectBookmarks (Local m) = map Local (collectBookmarks' m)
232+collectBookmarks (FromDep pkg m) = map (FromDep pkg) (collectBookmarks' m)
233+
234+collectBookmarks' :: P.Module -> [(P.ModuleName, String)]
235+collectBookmarks' m =
236+ map (P.getModuleName m, )
237+ (mapMaybe getDeclarationTitle
238+ (P.exportedDeclarations m))
239+
src/Language/PureScript/Docs/RenderedCode/Render.hs+2−9
@@ -20,8 +20,8 @@ import Language.PureScript.Kinds
2020import Language.PureScript.Pretty.Kinds
2121import Language.PureScript.Environment
2222
23−import Language.PureScript.Docs.MonoidExtras
2423import Language.PureScript.Docs.RenderedCode.Types
24+import Language.PureScript.Docs.Utils.MonoidExtras
2525
2626typeLiterals :: Pattern () Type RenderedCode
2727typeLiterals = mkPattern match
@@ -36,14 +36,8 @@ typeLiterals = mkPattern match
3636 , renderRow row
3737 , syntax "}"
3838 ]
39− match (PrettyPrintArray ty) =
40− Just $ mconcat
41− [ syntax "["
42− , renderType ty
43− , syntax "]"
44− ]
4539 match (TypeConstructor (Qualified mn name)) =
46− Just (ctor (show name) (toContainingModule mn))
40+ Just (ctor (show name) (maybeToContainingModule mn))
4741 match (ConstrainedType deps ty) =
4842 Just $ mintersperse sp
4943 [ syntax "(" <> constraints <> syntax ")"
@@ -137,7 +131,6 @@ dePrim other = other
137131
138132convert :: Type -> Type
139133convert (TypeApp (TypeApp f arg) ret) | f == tyFunction = PrettyPrintFunction arg ret
140−convert (TypeApp a el) | a == tyArray = PrettyPrintArray el
141134convert (TypeApp o r) | o == tyObject = PrettyPrintObject r
142135convert other = other
143136
src/Language/PureScript/Docs/RenderedCode/Types.hs+68−4
@@ -1,14 +1,19 @@
11{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+{-# LANGUAGE OverloadedStrings #-}
23
34-- | Data types and functions for representing a simplified form of PureScript
45-- code, intended for use in e.g. HTML documentation.
56
67module Language.PureScript.Docs.RenderedCode.Types
78 ( RenderedCodeElement(..)
9+ , asRenderedCodeElement
810 , ContainingModule(..)
9− , toContainingModule
11+ , asContainingModule
12+ , containingModuleToMaybe
13+ , maybeToContainingModule
1014 , fromContainingModule
1115 , RenderedCode
16+ , asRenderedCode
1217 , outputWith
1318 , sp
1419 , syntax
@@ -25,8 +30,12 @@ module Language.PureScript.Docs.RenderedCode.Types
2530 , keywordWhere
2631 ) where
2732
33+import Control.Applicative ((<$>), (<*>), (*>), pure)
2834import Data.Foldable
2935import Data.Monoid
36+import qualified Data.Aeson as A
37+import Data.Aeson.BetterErrors
38+import Control.Monad.Error.Class (MonadError(..))
3039
3140import qualified Language.PureScript as P
3241
@@ -43,6 +52,40 @@ data RenderedCodeElement
4352 | Space
4453 deriving (Show, Eq, Ord)
4554
55+instance A.ToJSON RenderedCodeElement where
56+ toJSON (Syntax str) =
57+ A.toJSON ["syntax", str]
58+ toJSON (Ident str) =
59+ A.toJSON ["ident", str]
60+ toJSON (Ctor str mn) =
61+ A.toJSON ["ctor", A.toJSON str, A.toJSON mn ]
62+ toJSON (Kind str) =
63+ A.toJSON ["kind", str]
64+ toJSON (Keyword str) =
65+ A.toJSON ["keyword", str]
66+ toJSON Space =
67+ A.toJSON ["space" :: String]
68+
69+asRenderedCodeElement :: Parse String RenderedCodeElement
70+asRenderedCodeElement =
71+ a Syntax "syntax" <|>
72+ a Ident "ident" <|>
73+ asCtor <|>
74+ a Kind "kind" <|>
75+ a Keyword "keyword" <|>
76+ asSpace <|>
77+ unableToParse
78+ where
79+ p <|> q = catchError p (const q)
80+
81+ a ctor' ctorStr = ctor' <$> (nth 0 (withString (eq ctorStr)) *> nth 1 asString)
82+ asCtor = nth 0 (withString (eq "ctor")) *> (Ctor <$> nth 1 asString <*> nth 2 asContainingModule)
83+ asSpace = nth 0 (withString (eq "space")) *> pure Space
84+
85+ eq s s' = if s == s' then Right () else Left ""
86+
87+ unableToParse = withString (Left . show)
88+
4689-- |
4790-- This type is isomorphic to 'Maybe' 'P.ModuleName'. It makes code a bit easier
4891-- to read, as the meaning is more explicit.
@@ -52,13 +95,28 @@ data ContainingModule
5295 | OtherModule P.ModuleName
5396 deriving (Show, Eq, Ord)
5497
98+instance A.ToJSON ContainingModule where
99+ toJSON mn = A.toJSON (P.runModuleName <$> containingModuleToMaybe mn)
100+
101+asContainingModule :: Parse e ContainingModule
102+asContainingModule =
103+ maybeToContainingModule <$> perhaps (P.moduleNameFromString <$> asString)
104+
55105-- |
56106-- Convert a 'Maybe' 'P.ModuleName' to a 'ContainingModule', using the obvious
57107-- isomorphism.
58108--
59−toContainingModule :: Maybe P.ModuleName -> ContainingModule
60−toContainingModule Nothing = ThisModule
61−toContainingModule (Just mn) = OtherModule mn
109+maybeToContainingModule :: Maybe P.ModuleName -> ContainingModule
110+maybeToContainingModule Nothing = ThisModule
111+maybeToContainingModule (Just mn) = OtherModule mn
112+
113+-- |
114+-- Convert a 'ContainingModule' to a 'Maybe' 'P.ModuleName', using the obvious
115+-- isomorphism.
116+--
117+containingModuleToMaybe :: ContainingModule -> Maybe P.ModuleName
118+containingModuleToMaybe ThisModule = Nothing
119+containingModuleToMaybe (OtherModule mn) = Just mn
62120
63121-- |
64122-- A version of 'fromMaybe' for 'ContainingModule' values.
@@ -75,6 +133,12 @@ newtype RenderedCode
75133 = RC { unRC :: [RenderedCodeElement] }
76134 deriving (Show, Eq, Ord, Monoid)
77135
136+instance A.ToJSON RenderedCode where
137+ toJSON (RC elems) = A.toJSON elems
138+
139+asRenderedCode :: Parse String RenderedCode
140+asRenderedCode = RC <$> eachInArray asRenderedCodeElement
141+
78142-- |
79143-- This function allows conversion of a 'RenderedCode' value into a value of
80144-- some other type (for example, plain text, or HTML). The first argument
src/Language/PureScript/Docs/Types.hs+238−9
@@ -1,3 +1,6 @@
1+{-# LANGUAGE RecordWildCards #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE TupleSections #-}
14
25module Language.PureScript.Docs.Types
36 ( module Language.PureScript.Docs.Types
@@ -5,24 +8,47 @@ module Language.PureScript.Docs.Types
58 )
69 where
710
11+import Control.Arrow (first, (***))
12+import Control.Applicative ((<$>), (<*>))
13+import Data.Char
14+import Data.Maybe (mapMaybe)
815import Data.Version
16+import Data.Aeson ((.=))
17+import qualified Data.Aeson as A
18+import Data.Aeson.BetterErrors
19+import Text.ParserCombinators.ReadP (readP_to_S)
20+import Data.Text (Text)
21+import qualified Data.Text as T
22+
23+import Web.Bower.PackageMeta hiding (Version)
24+
925import qualified Language.PureScript as P
1026
11−import Language.PureScript.Docs.RenderedCode as ReExports (RenderedCode, ContainingModule(..))
27+import Language.PureScript.Docs.RenderedCode as ReExports
28+ (RenderedCode, asRenderedCode,
29+ ContainingModule(..), asContainingModule,
30+ RenderedCodeElement(..), asRenderedCodeElement)
1231
13−data RenderedPackage = RenderedPackage
14− { rpName :: String
15− , rpVersion :: Version
16− , rpModules :: [RenderedModule]
32+--------------------
33+-- Types
34+
35+data UploadedPackage = UploadedPackage
36+ { pkgMeta :: PackageMeta
37+ , pkgVersion :: Version
38+ , pkgModules :: [RenderedModule]
39+ , pkgBookmarks :: [Bookmark]
40+ , pkgResolvedDependencies :: [(PackageName, Version)]
41+ , pkgGithub :: (GithubUser, GithubRepo)
42+ , pkgUploader :: Maybe GithubUser
1743 }
18− deriving (Show)
44+ deriving (Show, Eq, Ord)
1945
2046data RenderedModule = RenderedModule
2147 { rmName :: String
2248 , rmComments :: Maybe String
2349 , rmDeclarations :: [RenderedDeclaration]
2450 }
25− deriving (Show)
51+ deriving (Show, Eq, Ord)
2652
2753data RenderedDeclaration = RenderedDeclaration
2854 { rdTitle :: String
@@ -31,7 +57,7 @@ data RenderedDeclaration = RenderedDeclaration
3157 , rdSourceSpan :: Maybe P.SourceSpan
3258 , rdChildren :: [RenderedChildDeclaration]
3359 }
34− deriving (Show)
60+ deriving (Show, Eq, Ord)
3561
3662data RenderedChildDeclaration = RenderedChildDeclaration
3763 { rcdTitle :: String
@@ -40,10 +66,213 @@ data RenderedChildDeclaration = RenderedChildDeclaration
4066 , rcdSourceSpan :: Maybe P.SourceSpan
4167 , rcdType :: RenderedChildDeclarationType
4268 }
43− deriving (Show)
69+ deriving (Show, Eq, Ord)
4470
4571data RenderedChildDeclarationType
4672 = ChildInstance
4773 | ChildDataConstructor
4874 | ChildTypeClassMember
75+ deriving (Show, Eq, Ord, Bounded, Enum)
76+
77+childDeclTypeToString :: RenderedChildDeclarationType -> String
78+childDeclTypeToString = withHead toLower . drop 5 . show
79+ where
80+ withHead f (x:xs) = f x : xs
81+ withHead _ [] = []
82+
83+childDeclarationTypes :: [(String, RenderedChildDeclarationType)]
84+childDeclarationTypes =
85+ map (\t -> (childDeclTypeToString t, t)) [minBound .. maxBound]
86+
87+newtype GithubUser
88+ = GithubUser { runGithubUser :: String }
89+ deriving (Show, Eq, Ord)
90+
91+newtype GithubRepo
92+ = GithubRepo { runGithubRepo :: String }
4993 deriving (Show, Eq, Ord)
94+
95+data UploadedPackageError
96+ = ErrorInPackageMeta BowerError
97+ | InvalidVersion
98+ | InvalidDeclarationType
99+ | InvalidRenderedCode String
100+ deriving (Show, Eq, Ord)
101+
102+type Bookmark = InPackage (P.ModuleName, String)
103+
104+data InPackage a
105+ = Local a
106+ | FromDep PackageName a
107+ deriving (Show, Eq, Ord)
108+
109+instance Functor InPackage where
110+ fmap f (Local x) = Local (f x)
111+ fmap f (FromDep pkgName x) = FromDep pkgName (f x)
112+
113+takeLocal :: InPackage a -> Maybe a
114+takeLocal (Local a) = Just a
115+takeLocal _ = Nothing
116+
117+takeLocals :: [InPackage a] -> [a]
118+takeLocals = mapMaybe takeLocal
119+
120+ignorePackage :: InPackage a -> a
121+ignorePackage (Local x) = x
122+ignorePackage (FromDep _ x) = x
123+
124+----------------------
125+-- Parsing
126+
127+asUploadedPackage :: Parse UploadedPackageError UploadedPackage
128+asUploadedPackage =
129+ UploadedPackage <$> key "packageMeta" asPackageMeta .! ErrorInPackageMeta
130+ <*> key "version" asVersion
131+ <*> key "modules" (eachInArray asRenderedModule)
132+ <*> key "bookmarks" asBookmarks .! ErrorInPackageMeta
133+ <*> key "resolvedDependencies" asResolvedDependencies
134+ <*> key "github" asGithub
135+ <*> keyMay "uploader" (GithubUser <$> asString)
136+
137+asVersion :: Parse UploadedPackageError Version
138+asVersion = withString (maybe (Left InvalidVersion) Right . parseVersion')
139+
140+parseVersion' :: String -> Maybe Version
141+parseVersion' str =
142+ case filter (null . snd) $ readP_to_S parseVersion str of
143+ [(vers, "")] -> Just vers
144+ _ -> Nothing
145+
146+asRenderedModule :: Parse UploadedPackageError RenderedModule
147+asRenderedModule =
148+ RenderedModule <$> key "name" asString
149+ <*> key "comments" (perhaps asString)
150+ <*> key "declarations" (eachInArray asDeclaration)
151+
152+asDeclaration :: Parse UploadedPackageError RenderedDeclaration
153+asDeclaration =
154+ RenderedDeclaration <$> key "title" asString
155+ <*> key "comments" (perhaps asString)
156+ <*> key "code" asRenderedCode .! InvalidRenderedCode
157+ <*> key "sourceSpan" (perhaps asSourceSpan)
158+ <*> key "children" (eachInArray asRenderedChildDeclaration)
159+
160+asRenderedChildDeclaration :: Parse UploadedPackageError RenderedChildDeclaration
161+asRenderedChildDeclaration =
162+ RenderedChildDeclaration <$> key "title" asString
163+ <*> key "comments" (perhaps asString)
164+ <*> key "code" asRenderedCode .! InvalidRenderedCode
165+ <*> key "sourceSpan" (perhaps asSourceSpan)
166+ <*> key "type" asRenderedChildDeclarationType .!! InvalidDeclarationType
167+ where
168+ p .!! err = p .! const err
169+
170+asRenderedChildDeclarationType :: Parse UploadedPackageError RenderedChildDeclarationType
171+asRenderedChildDeclarationType =
172+ withString (maybe (Left InvalidDeclarationType) Right .
173+ flip lookup childDeclarationTypes)
174+
175+asSourcePos :: Parse e P.SourcePos
176+asSourcePos = P.SourcePos <$> nth 0 asIntegral
177+ <*> nth 1 asIntegral
178+
179+asBookmarks :: Parse BowerError [Bookmark]
180+asBookmarks = eachInArray asBookmark
181+
182+asBookmark :: Parse BowerError Bookmark
183+asBookmark =
184+ build <$> key "package" (perhaps (withString parsePackageName))
185+ <*> key "item" ((,) <$> nth 0 (P.moduleNameFromString <$> asString)
186+ <*> nth 1 asString)
187+ where
188+ build Nothing = Local
189+ build (Just pn) = FromDep pn
190+
191+asResolvedDependencies :: Parse UploadedPackageError [(PackageName, Version)]
192+asResolvedDependencies =
193+ eachInObjectWithKey (mapLeft ErrorInPackageMeta . parsePackageName . T.unpack) asVersion
194+ where
195+ mapLeft f (Left x) = Left (f x)
196+ mapLeft _ (Right x) = Right x
197+
198+asGithub :: Parse e (GithubUser, GithubRepo)
199+asGithub = (,) <$> nth 0 (GithubUser <$> asString)
200+ <*> nth 1 (GithubRepo <$> asString)
201+
202+asSourceSpan :: Parse e P.SourceSpan
203+asSourceSpan = P.SourceSpan <$> key "name" asString
204+ <*> key "start" asSourcePos
205+ <*> key "end" asSourcePos
206+
207+---------------------
208+-- ToJSON instances
209+
210+instance A.ToJSON UploadedPackage where
211+ toJSON UploadedPackage{..} =
212+ A.object $
213+ [ "packageMeta" .= pkgMeta
214+ , "version" .= showVersion pkgVersion
215+ , "modules" .= pkgModules
216+ , "bookmarks" .= map (fmap (first P.runModuleName)) pkgBookmarks
217+ , "resolvedDependencies" .= assocListToJSON (T.pack . runPackageName)
218+ (T.pack . showVersion)
219+ pkgResolvedDependencies
220+ , "github" .= pkgGithub
221+ ] ++ case pkgUploader of
222+ Just u -> [ "uploader" .= u ]
223+ Nothing -> []
224+
225+instance A.ToJSON RenderedModule where
226+ toJSON RenderedModule{..} =
227+ A.object [ "name" .= rmName
228+ , "comments" .= rmComments
229+ , "declarations" .= rmDeclarations
230+ ]
231+
232+instance A.ToJSON RenderedDeclaration where
233+ toJSON RenderedDeclaration{..} =
234+ A.object [ "title" .= rdTitle
235+ , "comments" .= rdComments
236+ , "code" .= rdCode
237+ , "sourceSpan" .= rdSourceSpan
238+ , "children" .= rdChildren
239+ ]
240+
241+instance A.ToJSON RenderedChildDeclaration where
242+ toJSON RenderedChildDeclaration{..} =
243+ A.object [ "title" .= rcdTitle
244+ , "comments" .= rcdComments
245+ , "code" .= rcdCode
246+ , "sourceSpan" .= rcdSourceSpan
247+ , "type" .= rcdType
248+ ]
249+
250+instance A.ToJSON RenderedChildDeclarationType where
251+ toJSON = A.toJSON . childDeclTypeToString
252+
253+instance A.ToJSON GithubUser where
254+ toJSON = A.toJSON . runGithubUser
255+
256+instance A.ToJSON GithubRepo where
257+ toJSON = A.toJSON . runGithubRepo
258+
259+-- | Given a function for turning association list keys into JSON object keys,
260+-- and a function for turning association list values to JSON string values,
261+-- turns an association list into a JSON object.
262+--
263+-- For example:
264+-- @assocListToJSON T.pack T.pack [("a", "b")]@ will give @{"a": "b"}@.
265+assocListToJSON :: (a -> Text) -> (b -> Text) -> [(a, b)] -> A.Value
266+assocListToJSON f g xs = A.object (map (uncurry (.=) . (f *** g)) xs)
267+
268+instance A.ToJSON a => A.ToJSON (InPackage a) where
269+ toJSON x =
270+ case x of
271+ Local y -> withPackage (Nothing :: Maybe ()) y
272+ FromDep pn y -> withPackage (Just pn) y
273+ where
274+ withPackage :: (A.ToJSON p, A.ToJSON x) => p -> x -> A.Value
275+ withPackage p y =
276+ A.object [ "package" .= p
277+ , "item" .= y
278+ ]
src/Language/PureScript/Docs/Utils/HtmlHelpers.hsnew file+20
@@ -0,0 +1,20 @@
1+
2+module Language.PureScript.Docs.Utils.HtmlHelpers where
3+
4+import Data.String
5+import Lucid
6+
7+text :: String -> Html ()
8+text = toHtml
9+
10+sp :: Html ()
11+sp = text " "
12+
13+para :: String -> Html () -> Html ()
14+para className content = p_ [class_ (fromString className)] content
15+
16+withClass :: String -> Html () -> Html ()
17+withClass className content = span_ [class_ (fromString className)] content
18+
19+linkTo :: String -> Html () -> Html ()
20+linkTo href inner = a_ [href_ (fromString href)] inner
src/Language/PureScript/Docs/MonoidExtras.hs → src/Language/PureScript/Docs/Utils/MonoidExtras.hsrenamed+1−1
@@ -1,4 +1,4 @@
1−module Language.PureScript.Docs.MonoidExtras where
1+module Language.PureScript.Docs.Utils.MonoidExtras where
22
33import Data.Monoid
44