@@ -10,9 +10,9 @@ module Language.PureScript.Docs.Types
12import Control.Arrow (first, (***))
12import Control.Arrow (first, (***))
13−import Control.Applicative ((<$>), (<*>))
13+import Control.Applicative ((<$>), (<*>), pure)
14+import Control.Monad (when)
14import Data.Functor ((<$))
15import Data.Functor ((<$))
16import Data.Maybe (mapMaybe)
16import Data.Maybe (mapMaybe)
17import Data.Version
17import Data.Version
18import Data.Aeson ((.=))
18import Data.Aeson ((.=))
@@ -23,7 +23,7 @@ import Data.Text (Text)
23import Data.ByteString.Lazy (ByteString)
23import Data.ByteString.Lazy (ByteString)
24import qualified Data.Text as T
24import qualified Data.Text as T
26−import Web.Bower.PackageMeta hiding (Version)
26+import Web.Bower.PackageMeta hiding (Version, displayError)
28import qualified Language.PureScript as P
28import qualified Language.PureScript as P
@@ -39,11 +39,14 @@ data Package a = Package
39 { pkgMeta :: PackageMeta
39 { pkgMeta :: PackageMeta
40 , pkgVersion :: Version
40 , pkgVersion :: Version
41 , pkgVersionTag :: String
41 , pkgVersionTag :: String
42− , pkgModules :: [RenderedModule]
42+ , pkgModules :: [Module]
43 , pkgBookmarks :: [Bookmark]
43 , pkgBookmarks :: [Bookmark]
44 , pkgResolvedDependencies :: [(PackageName, Version)]
44 , pkgResolvedDependencies :: [(PackageName, Version)]
45 , pkgGithub :: (GithubUser, GithubRepo)
45 , pkgGithub :: (GithubUser, GithubRepo)
46 , pkgUploader :: a
46 , pkgUploader :: a
47+ , pkgCompilerVersion :: Version
48+ -- ^ The version of the PureScript compiler which was used to generate
49+ -- this data. We store this in order to reject packages which are too old.
48 deriving (Show, Eq, Ord)
51 deriving (Show, Eq, Ord)
@@ -63,50 +66,105 @@ verifyPackage verifiedUser Package{..} =
63 pkgResolvedDependencies
66 pkgResolvedDependencies
65 verifiedUser
68 verifiedUser
67packageName :: Package a -> PackageName
71packageName :: Package a -> PackageName
68packageName = bowerName . pkgMeta
72packageName = bowerName . pkgMeta
70−data RenderedModule = RenderedModule
74+data Module = Module
71− { rmName :: String
75+ { modName :: String
72− , rmComments :: Maybe String
76+ , modComments :: Maybe String
73− , rmDeclarations :: [RenderedDeclaration]
77+ , modDeclarations :: [Declaration]
75 deriving (Show, Eq, Ord)
79 deriving (Show, Eq, Ord)
77−data RenderedDeclaration = RenderedDeclaration
81+data Declaration = Declaration
78− { rdTitle :: String
82+ { declTitle :: String
79− , rdComments :: Maybe String
83+ , declComments :: Maybe String
80− , rdCode :: RenderedCode
81− , rdSourceSpan :: Maybe P.SourceSpan
84+ , declSourceSpan :: Maybe P.SourceSpan
82− , rdChildren :: [RenderedChildDeclaration]
85+ , declChildren :: [ChildDeclaration]
86+ , declFixity :: Maybe P.Fixity
87+ , declInfo :: DeclarationInfo
84 deriving (Show, Eq, Ord)
89 deriving (Show, Eq, Ord)
86−data RenderedChildDeclaration = RenderedChildDeclaration
91+-- |
87− { rcdTitle :: String
92+-- A value of this type contains information that is specific to a particular
88− , rcdComments :: Maybe String
93+-- kind of declaration (as opposed to information which exists in all kinds of
89− , rcdCode :: RenderedCode
94+-- declarations, which goes into the 'Declaration' type directly).
90− , rcdSourceSpan :: Maybe P.SourceSpan
95+--
91− , rcdType :: RenderedChildDeclarationType
96+-- Many of the constructors are very similar to their equivalents in the real
92− }
97+-- PureScript AST, except that they have their name elided, since this is
98+-- already available via the rdTitle field of 'Declaration'.
102+ -- A value declaration, with its type.
104+ = ValueDeclaration P.Type
107+ -- A data/newtype declaration, with the kind of declaration (data or
108+ -- newtype) and its type arguments. Constructors are represented as child
111+ | DataDeclaration P.DataDeclType [(String, Maybe P.Kind)]
114+ -- A data type foreign import, with its kind.
116+ | ExternDataDeclaration P.Kind
119+ -- A type synonym, with its type arguments and its type.
121+ | TypeSynonymDeclaration [(String, Maybe P.Kind)] P.Type
124+ -- A type class, with its type arguments and its superclasses. Instances and
125+ -- members are represented as child declarations.
127+ | TypeClassDeclaration [(String, Maybe P.Kind)] [P.Constraint]
93 deriving (Show, Eq, Ord)
128 deriving (Show, Eq, Ord)
95−data RenderedChildDeclarationType
130+declInfoToString :: DeclarationInfo -> String
96− = ChildInstance
131+declInfoToString (ValueDeclaration _) = "value"
97− | ChildDataConstructor
132+declInfoToString (DataDeclaration _ _) = "data"
98− | ChildTypeClassMember
133+declInfoToString (ExternDataDeclaration _) = "externData"
134+declInfoToString (TypeSynonymDeclaration _ _) = "typeSynonym"
135+declInfoToString (TypeClassDeclaration _ _) = "typeClass"
137+data ChildDeclaration = ChildDeclaration
138+ { cdeclTitle :: String
139+ , cdeclComments :: Maybe String
140+ , cdeclSourceSpan :: Maybe P.SourceSpan
141+ , cdeclInfo :: ChildDeclarationInfo
99− deriving (Show, Eq, Ord, Bounded, Enum)
143+ deriving (Show, Eq, Ord)
101−childDeclTypeToString :: RenderedChildDeclarationType -> String
145+data ChildDeclarationInfo
102−childDeclTypeToString = withHead toLower . drop 5 . show
146+ -- |
103− where
147+ -- A type instance declaration, with its dependencies and its type.
104− withHead f (x:xs) = f x : xs
148+ --
105− withHead _ [] = []
149+ = ChildInstance [P.Constraint] P.Type
152+ -- A data constructor, with its type arguments.
154+ | ChildDataConstructor [P.Type]
157+ -- A type class member, with its type. Note that the type does not include
158+ -- the type class constraint; this may be added manually if desired. For
159+ -- example, `pure` from `Applicative` would be `forall a. a -> f a`.
161+ | ChildTypeClassMember P.Type
162+ deriving (Show, Eq, Ord)
107−childDeclarationTypes :: [(String, RenderedChildDeclarationType)]
164+childDeclInfoToString :: ChildDeclarationInfo -> String
108−childDeclarationTypes =
165+childDeclInfoToString (ChildInstance _ _) = "instance"
109− map (\t -> (childDeclTypeToString t, t)) [minBound .. maxBound]
166+childDeclInfoToString (ChildDataConstructor _) = "dataConstructor"
167+childDeclInfoToString (ChildTypeClassMember _) = "typeClassMember"
111newtype GithubUser
169newtype GithubUser
112 = GithubUser { runGithubUser :: String }
170 = GithubUser { runGithubUser :: String }
@@ -117,10 +175,16 @@ newtype GithubRepo
117 deriving (Show, Eq, Ord)
175 deriving (Show, Eq, Ord)
119data PackageError
177data PackageError
178+ = CompilerTooOld Version Version
179+ -- ^ Minimum allowable version for generating data with the current
180+ -- parser, and actual version used.
120− = ErrorInPackageMeta BowerError
181+ | ErrorInPackageMeta BowerError
121 | InvalidVersion
182 | InvalidVersion
122− | InvalidDeclarationType
183+ | InvalidDeclarationType String
123− | InvalidRenderedCode String
184+ | InvalidChildDeclarationType String
186+ | InvalidKind String
187+ | InvalidDataDeclType String
124 deriving (Show, Eq, Ord)
188 deriving (Show, Eq, Ord)
126type Bookmark = InPackage (P.ModuleName, String)
190type Bookmark = InPackage (P.ModuleName, String)
@@ -148,25 +212,33 @@ ignorePackage (FromDep _ x) = x
148----------------------
212----------------------
149-- Parsing
213-- Parsing
151−parseUploadedPackage :: ByteString -> Either (ParseError PackageError) UploadedPackage
215+parseUploadedPackage :: Version -> ByteString -> Either (ParseError PackageError) UploadedPackage
152−parseUploadedPackage = parse asUploadedPackage
216+parseUploadedPackage minVersion = parse $ asUploadedPackage minVersion
218+parseVerifiedPackage :: Version -> ByteString -> Either (ParseError PackageError) VerifiedPackage
219+parseVerifiedPackage minVersion = parse $ asVerifiedPackage minVersion
154−parseVerifiedPackage :: ByteString -> Either (ParseError PackageError) VerifiedPackage
221+asPackage :: Version -> (forall e. Parse e a) -> Parse PackageError (Package a)
155−parseVerifiedPackage = parse asVerifiedPackage
222+asPackage minimumVersion uploader = do
223+ -- If the compilerVersion key is missing, we can be sure that it was produced
224+ -- with 0.7.0.0, since that is the only released version that included the
225+ -- psc-publish tool before this key was added.
226+ compilerVersion <- keyOrDefault "compilerVersion" (Version [0,7,0,0] []) asVersion
227+ when (compilerVersion < minimumVersion)
228+ (throwCustomError $ CompilerTooOld minimumVersion compilerVersion)
157−asPackage :: (forall e. Parse e a) -> Parse PackageError (Package a)
159 Package <$> key "packageMeta" asPackageMeta .! ErrorInPackageMeta
230 Package <$> key "packageMeta" asPackageMeta .! ErrorInPackageMeta
160 <*> key "version" asVersion
231 <*> key "version" asVersion
161 <*> key "versionTag" asString
232 <*> key "versionTag" asString
162− <*> key "modules" (eachInArray asRenderedModule)
233+ <*> key "modules" (eachInArray asModule)
163 <*> key "bookmarks" asBookmarks .! ErrorInPackageMeta
234 <*> key "bookmarks" asBookmarks .! ErrorInPackageMeta
164 <*> key "resolvedDependencies" asResolvedDependencies
235 <*> key "resolvedDependencies" asResolvedDependencies
165 <*> key "github" asGithub
236 <*> key "github" asGithub
166 <*> key "uploader" uploader
237 <*> key "uploader" uploader
238+ <*> pure compilerVersion
168−asUploadedPackage :: Parse PackageError UploadedPackage
240+asUploadedPackage :: Version -> Parse PackageError UploadedPackage
169−asUploadedPackage = asPackage asNotYetKnown
241+asUploadedPackage minVersion = asPackage minVersion asNotYetKnown
171asNotYetKnown :: Parse e NotYetKnown
243asNotYetKnown :: Parse e NotYetKnown
172asNotYetKnown = NotYetKnown <$ asNull
244asNotYetKnown = NotYetKnown <$ asNull
@@ -174,8 +246,35 @@ asNotYetKnown = NotYetKnown <$ asNull
174instance A.FromJSON NotYetKnown where
246instance A.FromJSON NotYetKnown where
175 parseJSON = toAesonParser' asNotYetKnown
247 parseJSON = toAesonParser' asNotYetKnown
177−asVerifiedPackage :: Parse PackageError VerifiedPackage
249+asVerifiedPackage :: Version -> Parse PackageError VerifiedPackage
178−asVerifiedPackage = asPackage asGithubUser
250+asVerifiedPackage minVersion = asPackage minVersion asGithubUser
252+displayPackageError :: PackageError -> Text
253+displayPackageError e = case e of
254+ CompilerTooOld minV usedV ->
255+ "Expecting data produced by at least version " <> T.pack (showVersion minV)
256+ <> " of the compiler, but it appears that " <> T.pack (showVersion usedV)
258+ ErrorInPackageMeta err ->
259+ "Error in package metadata: " <> showBowerError err
262+ InvalidDeclarationType str ->
263+ "Invalid declaration type: \"" <> T.pack str <> "\""
264+ InvalidChildDeclarationType str ->
265+ "Invalid child declaration type: \"" <> T.pack str <> "\""
269+ "Invalid kind: \"" <> T.pack str <> "\""
270+ InvalidDataDeclType str ->
271+ "Invalid data declaration type: \"" <> T.pack str <> "\""
275+instance A.FromJSON a => A.FromJSON (Package a) where
276+ parseJSON = toAesonParser displayPackageError
277+ (asPackage (Version [0,0,0,0] []) fromAesonParser)
180asGithubUser :: Parse e GithubUser
279asGithubUser :: Parse e GithubUser
181asGithubUser = GithubUser <$> asString
280asGithubUser = GithubUser <$> asString
@@ -183,11 +282,6 @@ asGithubUser = GithubUser <$> asString
183instance A.FromJSON GithubUser where
282instance A.FromJSON GithubUser where
184 parseJSON = toAesonParser' asGithubUser
283 parseJSON = toAesonParser' asGithubUser
186−instance A.FromJSON a => A.FromJSON (Package a) where
187− -- TODO: actual error display
188− parseJSON = toAesonParser (T.pack . show)
189− (asPackage fromAesonParser)
191asVersion :: Parse PackageError Version
285asVersion :: Parse PackageError Version
192asVersion = withString (maybe (Left InvalidVersion) Right . parseVersion')
286asVersion = withString (maybe (Left InvalidVersion) Right . parseVersion')
@@ -197,39 +291,105 @@ parseVersion' str =
197 [(vers, "")] -> Just vers
291 [(vers, "")] -> Just vers
198 _ -> Nothing
292 _ -> Nothing
200−asRenderedModule :: Parse PackageError RenderedModule
294+asModule :: Parse PackageError Module
201−asRenderedModule =
295+asModule =
202− RenderedModule <$> key "name" asString
296+ Module <$> key "name" asString
203− <*> key "comments" (perhaps asString)
297+ <*> key "comments" (perhaps asString)
204− <*> key "declarations" (eachInArray asDeclaration)
298+ <*> key "declarations" (eachInArray asDeclaration)
206−asDeclaration :: Parse PackageError RenderedDeclaration
300+asDeclaration :: Parse PackageError Declaration
207asDeclaration =
301asDeclaration =
208− RenderedDeclaration <$> key "title" asString
302+ Declaration <$> key "title" asString
209− <*> key "comments" (perhaps asString)
303+ <*> key "comments" (perhaps asString)
210− <*> key "code" asRenderedCode .! InvalidRenderedCode
304+ <*> key "sourceSpan" (perhaps asSourceSpan)
211− <*> key "sourceSpan" (perhaps asSourceSpan)
305+ <*> key "children" (eachInArray asChildDeclaration)
212− <*> key "children" (eachInArray asRenderedChildDeclaration)
306+ <*> key "fixity" (perhaps asFixity)
213−
307+ <*> key "info" asDeclarationInfo
214−asRenderedChildDeclaration :: Parse PackageError RenderedChildDeclaration
308+
215−asRenderedChildDeclaration =
309+asFixity :: Parse PackageError P.Fixity
216− RenderedChildDeclaration <$> key "title" asString
310+asFixity = P.Fixity <$> key "associativity" asAssociativity
217− <*> key "comments" (perhaps asString)
311+ <*> key "precedence" asIntegral
218− <*> key "code" asRenderedCode .! InvalidRenderedCode
312+
219− <*> key "sourceSpan" (perhaps asSourceSpan)
313+parseAssociativity :: String -> Maybe P.Associativity
220− <*> key "type" asRenderedChildDeclarationType .!! InvalidDeclarationType
314+parseAssociativity str = case str of
315+ "infix" -> Just P.Infix
316+ "infixl" -> Just P.Infixl
317+ "infixr" -> Just P.Infixr
320+asAssociativity :: Parse PackageError P.Associativity
321+asAssociativity = withString (maybe (Left InvalidFixity) Right . parseAssociativity)
323+asDeclarationInfo :: Parse PackageError DeclarationInfo
324+asDeclarationInfo = do
325+ ty <- key "declType" asString
328+ ValueDeclaration <$> key "type" asType
330+ DataDeclaration <$> key "dataDeclType" asDataDeclType
331+ <*> key "typeArguments" asTypeArguments
333+ ExternDataDeclaration <$> key "kind" asKind
335+ TypeSynonymDeclaration <$> key "arguments" asTypeArguments
336+ <*> key "type" asType
338+ TypeClassDeclaration <$> key "arguments" asTypeArguments
339+ <*> key "superclasses" (eachInArray asConstraint)
341+ throwCustomError (InvalidDeclarationType other)
343+asTypeArguments :: Parse PackageError [(String, Maybe P.Kind)]
344+asTypeArguments = eachInArray asTypeArgument
222− p .!! err = p .! const err
346+ asTypeArgument = (,) <$> nth 0 asString <*> nth 1 (perhaps asKind)
348+asKind :: Parse e P.Kind
349+asKind = fromAesonParser
351+asType :: Parse e P.Type
352+asType = fromAesonParser
354+asDataDeclType :: Parse PackageError P.DataDeclType
356+ withString $ \s -> case s of
357+ "data" -> Right P.Data
358+ "newtype" -> Right P.Newtype
359+ other -> Left (InvalidDataDeclType other)
224−asRenderedChildDeclarationType :: Parse PackageError RenderedChildDeclarationType
361+asChildDeclaration :: Parse PackageError ChildDeclaration
225−asRenderedChildDeclarationType =
362+asChildDeclaration =
226− withString (maybe (Left InvalidDeclarationType) Right .
363+ ChildDeclaration <$> key "title" asString
227− flip lookup childDeclarationTypes)
364+ <*> key "comments" (perhaps asString)
365+ <*> key "sourceSpan" (perhaps asSourceSpan)
366+ <*> key "info" asChildDeclarationInfo
368+asChildDeclarationInfo :: Parse PackageError ChildDeclarationInfo
369+asChildDeclarationInfo = do
370+ ty <- key "declType" asString
373+ ChildInstance <$> key "dependencies" (eachInArray asConstraint)
374+ <*> key "type" asType
375+ "dataConstructor" ->
376+ ChildDataConstructor <$> key "arguments" (eachInArray asType)
377+ "typeClassMember" ->
378+ ChildTypeClassMember <$> key "type" asType
380+ throwCustomError $ InvalidChildDeclarationType other
229asSourcePos :: Parse e P.SourcePos
382asSourcePos :: Parse e P.SourcePos
230asSourcePos = P.SourcePos <$> nth 0 asIntegral
383asSourcePos = P.SourcePos <$> nth 0 asIntegral
231 <*> nth 1 asIntegral
384 <*> nth 1 asIntegral
386+asConstraint :: Parse PackageError P.Constraint
387+asConstraint = (,) <$> nth 0 asQualifiedProperName
388+ <*> nth 1 (eachInArray asType)
390+asQualifiedProperName :: Parse e (P.Qualified P.ProperName)
391+asQualifiedProperName = fromAesonParser
233asBookmarks :: Parse BowerError [Bookmark]
393asBookmarks :: Parse BowerError [Bookmark]
234asBookmarks = eachInArray asBookmark
394asBookmarks = eachInArray asBookmark
@@ -274,38 +434,54 @@ instance A.ToJSON a => A.ToJSON (Package a) where
274 pkgResolvedDependencies
434 pkgResolvedDependencies
275 , "github" .= pkgGithub
435 , "github" .= pkgGithub
276 , "uploader" .= pkgUploader
436 , "uploader" .= pkgUploader
437+ , "compilerVersion" .= showVersion P.version
279instance A.ToJSON NotYetKnown where
440instance A.ToJSON NotYetKnown where
280 toJSON _ = A.Null
441 toJSON _ = A.Null
282−instance A.ToJSON RenderedModule where
443+instance A.ToJSON Module where
283− toJSON RenderedModule{..} =
444+ toJSON Module{..} =
284− A.object [ "name" .= rmName
445+ A.object [ "name" .= modName
285− , "comments" .= rmComments
446+ , "comments" .= modComments
286− , "declarations" .= rmDeclarations
447+ , "declarations" .= modDeclarations
289−instance A.ToJSON RenderedDeclaration where
450+instance A.ToJSON Declaration where
290− toJSON RenderedDeclaration{..} =
451+ toJSON Declaration{..} =
291− A.object [ "title" .= rdTitle
452+ A.object [ "title" .= declTitle
292− , "comments" .= rdComments
453+ , "comments" .= declComments
293− , "code" .= rdCode
454+ , "sourceSpan" .= declSourceSpan
294− , "sourceSpan" .= rdSourceSpan
455+ , "children" .= declChildren
295− , "children" .= rdChildren
456+ , "fixity" .= declFixity
457+ , "info" .= declInfo
298−instance A.ToJSON RenderedChildDeclaration where
460+instance A.ToJSON ChildDeclaration where
299− toJSON RenderedChildDeclaration{..} =
461+ toJSON ChildDeclaration{..} =
300− A.object [ "title" .= rcdTitle
462+ A.object [ "title" .= cdeclTitle
301− , "comments" .= rcdComments
463+ , "comments" .= cdeclComments
302− , "code" .= rcdCode
464+ , "sourceSpan" .= cdeclSourceSpan
303− , "sourceSpan" .= rcdSourceSpan
465+ , "info" .= cdeclInfo
307−instance A.ToJSON RenderedChildDeclarationType where
468+instance A.ToJSON DeclarationInfo where
308− toJSON = A.toJSON . childDeclTypeToString
469+ toJSON info = A.object $ "declType" .= declInfoToString info : props
471+ props = case info of
472+ ValueDeclaration ty -> ["type" .= ty]
473+ DataDeclaration ty args -> ["dataDeclType" .= ty, "typeArguments" .= args]
474+ ExternDataDeclaration kind -> ["kind" .= kind]
475+ TypeSynonymDeclaration args ty -> ["arguments" .= args, "type" .= ty]
476+ TypeClassDeclaration args super -> ["arguments" .= args, "superclasses" .= super]
478+instance A.ToJSON ChildDeclarationInfo where
479+ toJSON info = A.object $ "declType" .= childDeclInfoToString info : props
481+ props = case info of
482+ ChildInstance deps ty -> ["dependencies" .= deps, "type" .= ty]
483+ ChildDataConstructor args -> ["arguments" .= args]
484+ ChildTypeClassMember ty -> ["type" .= ty]
310instance A.ToJSON GithubUser where
486instance A.ToJSON GithubUser where
311 toJSON = A.toJSON . runGithubUser
487 toJSON = A.toJSON . runGithubUser