purescript-0.15.15: src/Language/PureScript/Docs/Types.hs
module Language.PureScript.Docs.Types
( module Language.PureScript.Docs.Types
, module ReExports
)
where
import Protolude hiding (to, from, unlines)
import Prelude (String, unlines, lookup)
import Control.Arrow ((***))
import Data.Aeson ((.=))
import Data.Aeson.Key qualified as A.Key
import Data.Aeson.BetterErrors
(Parse, keyOrDefault, throwCustomError, key, asText,
keyMay, withString, eachInArray, asNull, (.!), toAesonParser, toAesonParser',
fromAesonParser, perhaps, withText, asIntegral, nth, eachInObjectWithKey,
asString)
import Data.Map qualified as Map
import Data.Time.Clock (UTCTime)
import Data.Time.Format qualified as TimeFormat
import Data.Version (Version(..), showVersion)
import Data.Aeson qualified as A
import Data.Text qualified as T
import Data.Vector qualified as V
import Language.PureScript.AST qualified as P
import Language.PureScript.CoreFn.FromJSON qualified as P
import Language.PureScript.Crash qualified as P
import Language.PureScript.Environment qualified as P
import Language.PureScript.Names qualified as P
import Language.PureScript.Roles qualified as P
import Language.PureScript.Types qualified as P
import Paths_purescript qualified as Paths
import Web.Bower.PackageMeta (BowerError, PackageMeta(..), PackageName, asPackageMeta, parsePackageName, runPackageName, showBowerError)
import Language.PureScript.Docs.RenderedCode as ReExports
(RenderedCode,
ContainingModule(..), asContainingModule,
RenderedCodeElement(..),
Namespace(..), FixityAlias)
import Language.PureScript.Publish.Registry.Compat (PursJsonError, showPursJsonError)
type Type' = P.Type ()
type Constraint' = P.Constraint ()
--------------------
-- Types
data Package a = Package
{ pkgMeta :: PackageMeta
, pkgVersion :: Version
, pkgVersionTag :: Text
-- TODO: When this field was introduced, it was given the Maybe type for the
-- sake of backwards compatibility, as older JSON blobs will not include the
-- field. It should eventually be changed to just UTCTime.
, pkgTagTime :: Maybe UTCTime
, pkgModules :: [Module]
, pkgModuleMap :: Map P.ModuleName PackageName
, pkgResolvedDependencies :: [(PackageName, Version)]
, pkgGithub :: (GithubUser, GithubRepo)
, pkgUploader :: a
, pkgCompilerVersion :: Version
-- ^ The version of the PureScript compiler which was used to generate
-- this data. We store this in order to reject packages which are too old.
}
deriving (Show, Eq, Ord, Generic)
instance NFData a => NFData (Package a)
data NotYetKnown = NotYetKnown
deriving (Show, Eq, Ord, Generic)
instance NFData NotYetKnown
type UploadedPackage = Package NotYetKnown
type VerifiedPackage = Package GithubUser
data ManifestError
= BowerManifest BowerError
| PursManifest PursJsonError
deriving (Show, Eq, Ord, Generic)
instance NFData ManifestError
showManifestError :: ManifestError -> Text
showManifestError = \case
BowerManifest err -> showBowerError err
PursManifest err -> showPursJsonError err
verifyPackage :: GithubUser -> UploadedPackage -> VerifiedPackage
verifyPackage verifiedUser Package{..} =
Package pkgMeta
pkgVersion
pkgVersionTag
pkgTagTime
pkgModules
pkgModuleMap
pkgResolvedDependencies
pkgGithub
verifiedUser
pkgCompilerVersion
packageName :: Package a -> PackageName
packageName = bowerName . pkgMeta
-- |
-- The time format used for serializing package tag times in the JSON format.
-- This is the ISO 8601 date format which includes a time and a timezone.
--
jsonTimeFormat :: String
jsonTimeFormat = "%Y-%m-%dT%H:%M:%S%z"
-- |
-- Convenience function for formatting a time in the format expected by this
-- module.
--
formatTime :: UTCTime -> String
formatTime =
TimeFormat.formatTime TimeFormat.defaultTimeLocale jsonTimeFormat
-- |
-- Convenience function for parsing a time in the format expected by this
-- module.
--
parseTime :: String -> Maybe UTCTime
parseTime =
TimeFormat.parseTimeM False TimeFormat.defaultTimeLocale jsonTimeFormat
data Module = Module
{ modName :: P.ModuleName
, modComments :: Maybe Text
, modDeclarations :: [Declaration]
-- Re-exported values from other modules
, modReExports :: [(InPackage P.ModuleName, [Declaration])]
}
deriving (Show, Eq, Ord, Generic)
instance NFData Module
data Declaration = Declaration
{ declTitle :: Text
, declComments :: Maybe Text
, declSourceSpan :: Maybe P.SourceSpan
, declChildren :: [ChildDeclaration]
, declInfo :: DeclarationInfo
, declKind :: Maybe KindInfo
}
deriving (Show, Eq, Ord, Generic)
instance NFData Declaration
-- |
-- A value of this type contains information that is specific to a particular
-- kind of declaration (as opposed to information which exists in all kinds of
-- declarations, which goes into the 'Declaration' type directly).
--
-- Many of the constructors are very similar to their equivalents in the real
-- PureScript AST, except that they have their name elided, since this is
-- already available via the rdTitle field of 'Declaration'.
--
data DeclarationInfo
-- |
-- A value declaration, with its type.
--
= ValueDeclaration Type'
-- |
-- A data/newtype declaration, with the kind of declaration (data or
-- newtype) and its type arguments. Constructors are represented as child
-- declarations.
--
| DataDeclaration P.DataDeclType [(Text, Maybe Type')] [P.Role]
-- |
-- A data type foreign import, with its kind.
--
| ExternDataDeclaration Type' [P.Role]
-- |
-- A type synonym, with its type arguments and its type.
--
| TypeSynonymDeclaration [(Text, Maybe Type')] Type'
-- |
-- A type class, with its type arguments, its superclasses and functional
-- dependencies. Instances and members are represented as child declarations.
--
| TypeClassDeclaration [(Text, Maybe Type')] [Constraint'] [([Text], [Text])]
-- |
-- An operator alias declaration, with the member the alias is for and the
-- operator's fixity.
--
| AliasDeclaration P.Fixity FixityAlias
deriving (Show, Eq, Ord, Generic)
instance NFData DeclarationInfo
-- |
-- Wraps enough information to properly render the kind signature
-- of a data/newtype/type/class declaration.
data KindInfo = KindInfo
{ kiKeyword :: P.KindSignatureFor
, kiKind :: Type'
}
deriving (Show, Eq, Ord, Generic)
instance NFData KindInfo
convertFundepsToStrings :: [(Text, Maybe Type')] -> [P.FunctionalDependency] -> [([Text], [Text])]
convertFundepsToStrings args fundeps =
map (\(P.FunctionalDependency from to) -> toArgs from to) fundeps
where
argsVec = V.fromList (map fst args)
getArg i =
fromMaybe
(P.internalError $ unlines
[ "convertDeclaration: Functional dependency index"
, show i
, "is bigger than arguments list"
, show (map fst args)
, "Functional dependencies are"
, show fundeps
]
) $ argsVec V.!? i
toArgs from to = (map getArg from, map getArg to)
declInfoToString :: DeclarationInfo -> Text
declInfoToString (ValueDeclaration _) = "value"
declInfoToString (DataDeclaration _ _ _) = "data"
declInfoToString (ExternDataDeclaration _ _) = "externData"
declInfoToString (TypeSynonymDeclaration _ _) = "typeSynonym"
declInfoToString (TypeClassDeclaration _ _ _) = "typeClass"
declInfoToString (AliasDeclaration _ _) = "alias"
declInfoNamespace :: DeclarationInfo -> Namespace
declInfoNamespace = \case
ValueDeclaration{} ->
ValueLevel
DataDeclaration{} ->
TypeLevel
ExternDataDeclaration{} ->
TypeLevel
TypeSynonymDeclaration{} ->
TypeLevel
TypeClassDeclaration{} ->
TypeLevel
AliasDeclaration _ alias ->
either (const TypeLevel) (const ValueLevel) (P.disqualify alias)
isTypeClass :: Declaration -> Bool
isTypeClass Declaration{..} =
case declInfo of
TypeClassDeclaration{} -> True
_ -> False
isValue :: Declaration -> Bool
isValue Declaration{..} =
case declInfo of
ValueDeclaration{} -> True
_ -> False
isType :: Declaration -> Bool
isType Declaration{..} =
case declInfo of
TypeSynonymDeclaration{} -> True
DataDeclaration{} -> True
ExternDataDeclaration{} -> True
_ -> False
isValueAlias :: Declaration -> Bool
isValueAlias Declaration{..} =
case declInfo of
AliasDeclaration _ (P.Qualified _ d) -> isRight d
_ -> False
isTypeAlias :: Declaration -> Bool
isTypeAlias Declaration{..} =
case declInfo of
AliasDeclaration _ (P.Qualified _ d) -> isLeft d
_ -> False
-- | Discard any children which do not satisfy the given predicate.
filterChildren :: (ChildDeclaration -> Bool) -> Declaration -> Declaration
filterChildren p decl =
decl { declChildren = filter p (declChildren decl) }
data ChildDeclaration = ChildDeclaration
{ cdeclTitle :: Text
, cdeclComments :: Maybe Text
, cdeclSourceSpan :: Maybe P.SourceSpan
, cdeclInfo :: ChildDeclarationInfo
}
deriving (Show, Eq, Ord, Generic)
instance NFData ChildDeclaration
data ChildDeclarationInfo
-- |
-- A type instance declaration, with its dependencies and its type.
--
= ChildInstance [Constraint'] Type'
-- |
-- A data constructor, with its type arguments.
--
| ChildDataConstructor [Type']
-- |
-- A type class member, with its type. Note that the type does not include
-- the type class constraint; this may be added manually if desired. For
-- example, `pure` from `Applicative` would be `forall a. a -> f a`.
--
| ChildTypeClassMember Type'
deriving (Show, Eq, Ord, Generic)
instance NFData ChildDeclarationInfo
childDeclInfoToString :: ChildDeclarationInfo -> Text
childDeclInfoToString (ChildInstance _ _) = "instance"
childDeclInfoToString (ChildDataConstructor _) = "dataConstructor"
childDeclInfoToString (ChildTypeClassMember _) = "typeClassMember"
childDeclInfoNamespace :: ChildDeclarationInfo -> Namespace
childDeclInfoNamespace =
-- We could just write this as `const ValueLevel` but by doing it this way,
-- if another constructor is added, we get a warning which acts as a prompt
-- to update this, instead of having this function (possibly incorrectly)
-- just return ValueLevel for the new constructor.
\case
ChildInstance{} ->
ValueLevel
ChildDataConstructor{} ->
ValueLevel
ChildTypeClassMember{} ->
ValueLevel
isTypeClassMember :: ChildDeclaration -> Bool
isTypeClassMember ChildDeclaration{..} =
case cdeclInfo of
ChildTypeClassMember{} -> True
_ -> False
isDataConstructor :: ChildDeclaration -> Bool
isDataConstructor ChildDeclaration{..} =
case cdeclInfo of
ChildDataConstructor{} -> True
_ -> False
newtype GithubUser
= GithubUser { runGithubUser :: Text }
deriving (Show, Eq, Ord, Generic)
instance NFData GithubUser
newtype GithubRepo
= GithubRepo { runGithubRepo :: Text }
deriving (Show, Eq, Ord, Generic)
instance NFData GithubRepo
data PackageError
= CompilerTooOld Version Version
-- ^ Minimum allowable version for generating data with the current
-- parser, and actual version used.
| ErrorInPackageMeta ManifestError
| InvalidVersion
| InvalidDeclarationType Text
| InvalidChildDeclarationType Text
| InvalidFixity
| InvalidKind Text
| InvalidDataDeclType Text
| InvalidKindSignatureFor Text
| InvalidTime
| InvalidRole Text
deriving (Show, Eq, Ord, Generic)
instance NFData PackageError
data InPackage a
= Local a
| FromDep PackageName a
deriving (Show, Eq, Ord, Generic)
instance NFData a => NFData (InPackage a)
instance Functor InPackage where
fmap f (Local x) = Local (f x)
fmap f (FromDep pkgName x) = FromDep pkgName (f x)
ignorePackage :: InPackage a -> a
ignorePackage (Local x) = x
ignorePackage (FromDep _ x) = x
----------------------------------------------------
-- Types for links between declarations
data LinksContext = LinksContext
{ ctxGithub :: (GithubUser, GithubRepo)
, ctxModuleMap :: Map P.ModuleName PackageName
, ctxResolvedDependencies :: [(PackageName, Version)]
, ctxPackageName :: PackageName
, ctxVersion :: Version
, ctxVersionTag :: Text
}
deriving (Show, Eq, Ord, Generic)
instance NFData LinksContext
data DocLink = DocLink
{ linkLocation :: LinkLocation
, linkTitle :: Text
, linkNamespace :: Namespace
}
deriving (Show, Eq, Ord, Generic)
instance NFData DocLink
data LinkLocation
-- | A link to a declaration in the current package.
= LocalModule P.ModuleName
-- | A link to a declaration in a different package. The arguments represent
-- the name of the other package, the version of the other package, and the
-- name of the module in the other package that the declaration is in.
| DepsModule PackageName Version P.ModuleName
-- | A link to a declaration that is built in to the compiler, e.g. the Prim
-- module. In this case we only need to store the module that the builtin
-- comes from. Note that all builtin modules begin with "Prim", and that the
-- compiler rejects attempts to define modules whose names start with "Prim".
| BuiltinModule P.ModuleName
deriving (Show, Eq, Ord, Generic)
instance NFData LinkLocation
-- | Given a links context, the current module name, the namespace of a thing
-- to link to, its title, and its containing module, attempt to create a
-- DocLink.
getLink :: LinksContext -> P.ModuleName -> Namespace -> Text -> ContainingModule -> Maybe DocLink
getLink LinksContext{..} curMn namespace target containingMod = do
location <- getLinkLocation
return DocLink
{ linkLocation = location
, linkTitle = target
, linkNamespace = namespace
}
where
getLinkLocation = builtinLinkLocation <|> normalLinkLocation
normalLinkLocation = do
case containingMod of
ThisModule ->
return $ LocalModule curMn
OtherModule destMn ->
case Map.lookup destMn ctxModuleMap of
Nothing ->
return $ LocalModule destMn
Just pkgName -> do
pkgVersion <- lookup pkgName ctxResolvedDependencies
return $ DepsModule pkgName pkgVersion destMn
builtinLinkLocation =
case containingMod of
OtherModule mn | P.isBuiltinModuleName mn ->
pure $ BuiltinModule mn
_ ->
empty
getLinksContext :: Package a -> LinksContext
getLinksContext Package{..} =
LinksContext
{ ctxGithub = pkgGithub
, ctxModuleMap = pkgModuleMap
, ctxResolvedDependencies = pkgResolvedDependencies
, ctxPackageName = bowerName pkgMeta
, ctxVersion = pkgVersion
, ctxVersionTag = pkgVersionTag
}
----------------------
-- Parsing
asPackage :: Version -> (forall e. Parse e a) -> Parse PackageError (Package a)
asPackage minimumVersion uploader = do
-- If the compilerVersion key is missing, we can be sure that it was produced
-- with 0.7.0.0, since that is the only released version that included the
-- `psc-publish` tool (now `purs publish`) before this key was added.
compilerVersion <- keyOrDefault "compilerVersion" (Version [0,7,0,0] []) asVersion
when (compilerVersion < minimumVersion)
(throwCustomError $ CompilerTooOld minimumVersion compilerVersion)
Package <$> key "packageMeta" asPackageMeta .! (ErrorInPackageMeta . BowerManifest)
<*> key "version" asVersion
<*> key "versionTag" asText
<*> keyMay "tagTime" (withString parseTimeEither)
<*> key "modules" (eachInArray asModule)
<*> moduleMap
<*> key "resolvedDependencies" asResolvedDependencies
<*> key "github" asGithub
<*> key "uploader" uploader
<*> pure compilerVersion
where
moduleMap =
key "moduleMap" asModuleMap
`pOr` (key "bookmarks" bookmarksAsModuleMap .! ErrorInPackageMeta)
parseTimeEither :: String -> Either PackageError UTCTime
parseTimeEither =
maybe (Left InvalidTime) Right . parseTime
asUploadedPackage :: Version -> Parse PackageError UploadedPackage
asUploadedPackage minVersion = asPackage minVersion asNotYetKnown
asNotYetKnown :: Parse e NotYetKnown
asNotYetKnown = NotYetKnown <$ asNull
instance A.FromJSON NotYetKnown where
parseJSON = toAesonParser' asNotYetKnown
displayPackageError :: PackageError -> Text
displayPackageError e = case e of
CompilerTooOld minV usedV ->
"Expecting data produced by at least version " <> T.pack (showVersion minV)
<> " of the compiler, but it appears that " <> T.pack (showVersion usedV)
<> " was used."
ErrorInPackageMeta err ->
"Error in package metadata: " <> showManifestError err
InvalidVersion ->
"Invalid version"
InvalidDeclarationType str ->
"Invalid declaration type: \"" <> str <> "\""
InvalidChildDeclarationType str ->
"Invalid child declaration type: \"" <> str <> "\""
InvalidFixity ->
"Invalid fixity"
InvalidKind str ->
"Invalid kind: \"" <> str <> "\""
InvalidDataDeclType str ->
"Invalid data declaration type: \"" <> str <> "\""
InvalidKindSignatureFor str ->
"Invalid kind signature keyword: \"" <> str <> "\""
InvalidTime ->
"Invalid time"
InvalidRole str ->
"Invalid role keyword: \"" <> str <> "\""
instance A.FromJSON a => A.FromJSON (Package a) where
parseJSON = toAesonParser displayPackageError
(asPackage (Version [0,0,0,0] []) fromAesonParser)
asGithubUser :: Parse e GithubUser
asGithubUser = GithubUser <$> asText
instance A.FromJSON GithubUser where
parseJSON = toAesonParser' asGithubUser
asVersion :: Parse PackageError Version
asVersion = withString (maybe (Left InvalidVersion) Right . P.parseVersion')
asModule :: Parse PackageError Module
asModule =
Module <$> key "name" (P.moduleNameFromString <$> asText)
<*> key "comments" (perhaps asText)
<*> key "declarations" (eachInArray asDeclaration)
<*> key "reExports" (eachInArray asReExport)
asDeclaration :: Parse PackageError Declaration
asDeclaration =
Declaration <$> key "title" asText
<*> key "comments" (perhaps asText)
<*> key "sourceSpan" (perhaps asSourceSpan)
<*> key "children" (eachInArray asChildDeclaration)
<*> key "info" asDeclarationInfo
<*> keyOrDefault "kind" Nothing (perhaps asKindInfo)
asReExport :: Parse PackageError (InPackage P.ModuleName, [Declaration])
asReExport =
(,) <$> key "moduleName" asReExportModuleName
<*> key "declarations" (eachInArray asDeclaration)
where
-- This is to preserve backwards compatibility with 0.10.3 and earlier versions
-- of the compiler, where the modReExports field had the type
-- [(P.ModuleName, [Declaration])]. This should eventually be removed,
-- possibly at the same time as the next breaking change to this JSON format.
asReExportModuleName :: Parse PackageError (InPackage P.ModuleName)
asReExportModuleName =
asInPackage fromAesonParser .! ErrorInPackageMeta
`pOr` fmap Local fromAesonParser
pOr :: Parse e a -> Parse e a -> Parse e a
p `pOr` q = catchError p (const q)
asInPackage :: Parse ManifestError a -> Parse ManifestError (InPackage a)
asInPackage inner =
build <$> key "package" (perhaps (withText (mapLeft BowerManifest . parsePackageName)))
<*> key "item" inner
where
build Nothing = Local
build (Just pn) = FromDep pn
asFixity :: Parse PackageError P.Fixity
asFixity =
P.Fixity <$> key "associativity" asAssociativity
<*> key "precedence" asIntegral
asFixityAlias :: Parse PackageError FixityAlias
asFixityAlias = fromAesonParser
parseAssociativity :: String -> Maybe P.Associativity
parseAssociativity str = case str of
"infix" -> Just P.Infix
"infixl" -> Just P.Infixl
"infixr" -> Just P.Infixr
_ -> Nothing
asAssociativity :: Parse PackageError P.Associativity
asAssociativity = withString (maybe (Left InvalidFixity) Right . parseAssociativity)
asDeclarationInfo :: Parse PackageError DeclarationInfo
asDeclarationInfo = do
ty <- key "declType" asText
case ty of
"value" ->
ValueDeclaration <$> key "type" asType
"data" ->
DataDeclaration <$> key "dataDeclType" asDataDeclType
<*> key "typeArguments" asTypeArguments
<*> keyOrDefault "roles" [] (eachInArray asRole)
"externData" ->
ExternDataDeclaration <$> key "kind" asType
<*> keyOrDefault "roles" [] (eachInArray asRole)
"typeSynonym" ->
TypeSynonymDeclaration <$> key "arguments" asTypeArguments
<*> key "type" asType
"typeClass" ->
TypeClassDeclaration <$> key "arguments" asTypeArguments
<*> key "superclasses" (eachInArray asConstraint)
<*> keyOrDefault "fundeps" [] asFunDeps
"alias" ->
AliasDeclaration <$> key "fixity" asFixity
<*> key "alias" asFixityAlias
-- Backwards compat: kinds are extern data
"kind" ->
pure $ ExternDataDeclaration (P.kindType $> ()) []
other ->
throwCustomError (InvalidDeclarationType other)
asKindInfo :: Parse PackageError KindInfo
asKindInfo =
KindInfo <$> key "keyword" asKindSignatureFor
<*> key "kind" asType
asKindSignatureFor :: Parse PackageError P.KindSignatureFor
asKindSignatureFor =
withText $ \case
"data" -> Right P.DataSig
"newtype" -> Right P.NewtypeSig
"class" -> Right P.ClassSig
"type" -> Right P.TypeSynonymSig
x -> Left (InvalidKindSignatureFor x)
asTypeArguments :: Parse PackageError [(Text, Maybe Type')]
asTypeArguments = eachInArray asTypeArgument
where
asTypeArgument = (,) <$> nth 0 asText <*> nth 1 (perhaps asType)
asRole :: Parse PackageError P.Role
asRole =
withText $ \case
"Representational" -> Right P.Representational
"Nominal" -> Right P.Nominal
"Phantom" -> Right P.Phantom
other -> Left (InvalidRole other)
asType :: Parse e Type'
asType = fromAesonParser
asFunDeps :: Parse PackageError [([Text], [Text])]
asFunDeps = eachInArray asFunDep
where
asFunDep = (,) <$> nth 0 (eachInArray asText) <*> nth 1 (eachInArray asText)
asDataDeclType :: Parse PackageError P.DataDeclType
asDataDeclType =
withText $ \case
"data" -> Right P.Data
"newtype" -> Right P.Newtype
other -> Left (InvalidDataDeclType other)
asChildDeclaration :: Parse PackageError ChildDeclaration
asChildDeclaration =
ChildDeclaration <$> key "title" asText
<*> key "comments" (perhaps asText)
<*> key "sourceSpan" (perhaps asSourceSpan)
<*> key "info" asChildDeclarationInfo
asChildDeclarationInfo :: Parse PackageError ChildDeclarationInfo
asChildDeclarationInfo = do
ty <- key "declType" asText
case ty of
"instance" ->
ChildInstance <$> key "dependencies" (eachInArray asConstraint)
<*> key "type" asType
"dataConstructor" ->
ChildDataConstructor <$> key "arguments" (eachInArray asType)
"typeClassMember" ->
ChildTypeClassMember <$> key "type" asType
other ->
throwCustomError $ InvalidChildDeclarationType other
asSourcePos :: Parse e P.SourcePos
asSourcePos = P.SourcePos <$> nth 0 asIntegral
<*> nth 1 asIntegral
asConstraint :: Parse PackageError Constraint'
asConstraint = P.Constraint () <$> key "constraintClass" asQualifiedProperName
<*> keyOrDefault "constraintKindArgs" [] (eachInArray asType)
<*> key "constraintArgs" (eachInArray asType)
<*> pure Nothing
asQualifiedProperName :: Parse e (P.Qualified (P.ProperName a))
asQualifiedProperName = fromAesonParser
asModuleMap :: Parse PackageError (Map P.ModuleName PackageName)
asModuleMap =
Map.fromList <$>
eachInObjectWithKey (Right . P.moduleNameFromString)
(withText parsePackageName')
-- This is here to preserve backwards compatibility with compilers which used
-- to generate a 'bookmarks' field in the JSON (i.e. up to 0.10.5). We should
-- remove this after the next breaking change to the JSON.
bookmarksAsModuleMap :: Parse ManifestError (Map P.ModuleName PackageName)
bookmarksAsModuleMap =
convert <$>
eachInArray (asInPackage (nth 0 (P.moduleNameFromString <$> asText)))
where
convert :: [InPackage P.ModuleName] -> Map P.ModuleName PackageName
convert = Map.fromList . mapMaybe toTuple
toTuple (Local _) = Nothing
toTuple (FromDep pkgName mn) = Just (mn, pkgName)
asResolvedDependencies :: Parse PackageError [(PackageName, Version)]
asResolvedDependencies =
eachInObjectWithKey parsePackageName' asVersion
parsePackageName' :: Text -> Either PackageError PackageName
parsePackageName' =
mapLeft ErrorInPackageMeta . (mapLeft BowerManifest . parsePackageName)
mapLeft :: (a -> a') -> Either a b -> Either a' b
mapLeft f (Left x) = Left (f x)
mapLeft _ (Right x) = Right x
asGithub :: Parse e (GithubUser, GithubRepo)
asGithub = (,) <$> nth 0 (GithubUser <$> asText)
<*> nth 1 (GithubRepo <$> asText)
asSourceSpan :: Parse e P.SourceSpan
asSourceSpan = P.SourceSpan <$> key "name" asString
<*> key "start" asSourcePos
<*> key "end" asSourcePos
---------------------
-- ToJSON instances
instance A.ToJSON a => A.ToJSON (Package a) where
toJSON Package{..} =
A.object $
[ "packageMeta" .= pkgMeta
, "version" .= showVersion pkgVersion
, "versionTag" .= pkgVersionTag
, "modules" .= pkgModules
, "moduleMap" .= assocListToJSON (A.Key.fromText . P.runModuleName)
runPackageName
(Map.toList pkgModuleMap)
, "resolvedDependencies" .= assocListToJSON (A.Key.fromText . runPackageName)
(T.pack . showVersion)
pkgResolvedDependencies
, "github" .= pkgGithub
, "uploader" .= pkgUploader
, "compilerVersion" .= showVersion Paths.version
] ++
fmap (\t -> "tagTime" .= formatTime t) (maybeToList pkgTagTime)
instance A.ToJSON NotYetKnown where
toJSON _ = A.Null
instance A.ToJSON Module where
toJSON Module{..} =
A.object [ "name" .= P.runModuleName modName
, "comments" .= modComments
, "declarations" .= modDeclarations
, "reExports" .= map toObj modReExports
]
where
toObj (mn, decls) = A.object [ "moduleName" .= mn
, "declarations" .= decls
]
instance A.ToJSON Declaration where
toJSON Declaration{..} =
A.object [ "title" .= declTitle
, "comments" .= declComments
, "sourceSpan" .= declSourceSpan
, "children" .= declChildren
, "info" .= declInfo
, "kind" .= declKind
]
instance A.ToJSON KindInfo where
toJSON KindInfo{..} =
A.object [ "keyword" .= kindSignatureForKeyword kiKeyword
, "kind" .= kiKind
]
kindSignatureForKeyword :: P.KindSignatureFor -> Text
kindSignatureForKeyword = \case
P.DataSig -> "data"
P.NewtypeSig -> "newtype"
P.TypeSynonymSig -> "type"
P.ClassSig -> "class"
instance A.ToJSON ChildDeclaration where
toJSON ChildDeclaration{..} =
A.object [ "title" .= cdeclTitle
, "comments" .= cdeclComments
, "sourceSpan" .= cdeclSourceSpan
, "info" .= cdeclInfo
]
instance A.ToJSON DeclarationInfo where
toJSON info = A.object $ "declType" .= declInfoToString info : props
where
props = case info of
ValueDeclaration ty -> ["type" .= ty]
DataDeclaration ty args roles -> ["dataDeclType" .= ty, "typeArguments" .= args, "roles" .= roles]
ExternDataDeclaration kind roles -> ["kind" .= kind, "roles" .= roles]
TypeSynonymDeclaration args ty -> ["arguments" .= args, "type" .= ty]
TypeClassDeclaration args super fundeps -> ["arguments" .= args, "superclasses" .= super, "fundeps" .= fundeps]
AliasDeclaration fixity alias -> ["fixity" .= fixity, "alias" .= alias]
instance A.ToJSON ChildDeclarationInfo where
toJSON info = A.object $ "declType" .= childDeclInfoToString info : props
where
props = case info of
ChildInstance deps ty -> ["dependencies" .= deps, "type" .= ty]
ChildDataConstructor args -> ["arguments" .= args]
ChildTypeClassMember ty -> ["type" .= ty]
instance A.ToJSON GithubUser where
toJSON = A.toJSON . runGithubUser
instance A.ToJSON GithubRepo where
toJSON = A.toJSON . runGithubRepo
-- | Given a function for turning association list keys into JSON object keys,
-- and a function for turning association list values to JSON string values,
-- turns an association list into a JSON object.
--
-- For example:
-- @assocListToJSON T.pack T.pack [("a", "b")]@ will give @{"a": "b"}@.
assocListToJSON :: (a -> A.Key) -> (b -> Text) -> [(a, b)] -> A.Value
assocListToJSON f g xs = A.object (map (uncurry (.=) . (f *** g)) xs)
instance A.ToJSON a => A.ToJSON (InPackage a) where
toJSON x =
case x of
Local y -> withPackage (Nothing :: Maybe ()) y
FromDep pn y -> withPackage (Just pn) y
where
withPackage :: (A.ToJSON p, A.ToJSON x) => p -> x -> A.Value
withPackage p y =
A.object [ "package" .= p
, "item" .= y
]