diff --git a/src/Language/PureScript/Docs/AsHtml.hs b/src/Language/PureScript/Docs/AsHtml.hs
index 3fc7074c76..473928a5bd 100644
--- a/src/Language/PureScript/Docs/AsHtml.hs
+++ b/src/Language/PureScript/Docs/AsHtml.hs
@@ -179,12 +179,20 @@ renderChildren r xs = ul $ mapM_ item xs
where
item decl =
li ! A.id (v (T.drop 1 (fragment decl))) $ do
- renderCode decl
+ case Render.renderChildDeclaration decl of
+ Render.RenderedAsCode renderedCode -> renderCode renderedCode
+ Render.RenderedAsStructure struct ->
+ ul $ for_ struct $ \(instChainEl, el) -> do
+ li ! A.id (v (T.drop 1 (subFragement decl (icTitle instChainEl)))) $ (renderCode el)
+ for_ (icComments instChainEl) $ \coms ->
+ H.div ! A.class_ "decl__child__comments" $ renderMarkdown coms
for_ (cdeclComments decl) $ \coms ->
H.div ! A.class_ "decl__child_comments" $ renderMarkdown coms
fragment decl = makeFragment (childDeclInfoNamespace (cdeclInfo decl)) (cdeclTitle decl)
- renderCode = code . codeAsHtml r . Render.renderChildDeclaration
+ subFragement decl subTitle = makeFragment (childDeclInfoNamespace (cdeclInfo decl)) subTitle
+ renderCode = code . codeAsHtml r
+ --codes = code <$> codeAsHtml r <$> Render.renderChildDeclaration codes
codeAsHtml :: HtmlRenderContext -> RenderedCode -> Html
codeAsHtml r = outputWith elemAsHtml
@@ -329,7 +337,8 @@ partitionChildren =
where
go (instances, dctors, members) rcd =
case cdeclInfo rcd of
- ChildInstance _ _ -> (rcd : instances, dctors, members)
+ ChildInstanceChain _ -> (rcd : instances, dctors, members)
+ ChildPartOfInstanceChain _ -> (rcd : instances, dctors, members)
ChildDataConstructor _ -> (instances, rcd : dctors, members)
ChildTypeClassMember _ -> (instances, dctors, rcd : members)
diff --git a/src/Language/PureScript/Docs/AsMarkdown.hs b/src/Language/PureScript/Docs/AsMarkdown.hs
index 1177de0026..3c6fabc246 100644
--- a/src/Language/PureScript/Docs/AsMarkdown.hs
+++ b/src/Language/PureScript/Docs/AsMarkdown.hs
@@ -45,18 +45,19 @@ declAsMarkdown decl@Declaration{..} = do
let (instances, children) = partition (isChildInstance . cdeclInfo) declChildren
fencedBlock $ do
tell' (codeToString $ Render.renderDeclaration decl)
- zipWithM_ (\f c -> tell' (childToString f c)) (First : repeat NotFirst) children
+ zipWithM_ (\f c -> childToString f c) (First : repeat NotFirst) children
spacer
for_ declComments tell'
unless (null instances) $ do
headerLevel 5 "Instances"
- fencedBlock $ mapM_ (tell' . childToString NotFirst) instances
+ mapM_ (childToString NotFirst) instances
spacer
where
- isChildInstance (ChildInstance _ _) = True
+ isChildInstance (ChildInstanceChain _ ) = True
+ isChildInstance (ChildPartOfInstanceChain _) = True
isChildInstance _ = False
codeToString :: RenderedCode -> Text
@@ -81,18 +82,31 @@ codeToString = outputWith elemAsMarkdown
-- P.Infixr -> "right-associative"
-- P.Infix -> "non-associative"
-childToString :: First -> ChildDeclaration -> Text
+childToString :: First -> ChildDeclaration -> Docs
childToString f decl@ChildDeclaration{..} =
case cdeclInfo of
ChildDataConstructor _ ->
let c = if f == First then "=" else "|"
- in " " <> c <> " " <> str
+ in fencedBlock $ do
+ tell' $ " " <> c <> " "
+ str
ChildTypeClassMember _ ->
- " " <> str
- ChildInstance _ _ ->
+ fencedBlock $ do
+ tell' $ " "
+ str
+ ChildInstanceChain _ ->
str
+ ChildPartOfInstanceChain _ ->
+ fencedBlock $ str
where
- str = codeToString $ Render.renderChildDeclaration decl
+ str = case Render.renderChildDeclaration decl of
+ Render.RenderedAsCode code -> tell' $ codeToString code
+ Render.RenderedAsStructure structure -> mapM_ chainInstanceToString structure
+
+ chainInstanceToString :: (ChildInstanceChainInfo, RenderedCode) -> Docs
+ chainInstanceToString (inst, code) = do
+ fencedBlock $ tell' $ codeToString code
+ mapM_ tell' $ icComments inst
data First
= First
diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs
index 6300ae9990..4eecf523d9 100644
--- a/src/Language/PureScript/Docs/Convert/Single.hs
+++ b/src/Language/PureScript/Docs/Convert/Single.hs
@@ -69,6 +69,13 @@ type IntermediateDeclaration
-- module is an instance of a type class also defined in that module).
data DeclarationAugment
= AugmentChild ChildDeclaration
+ -- ^ Augments a declaration (like type class or type)
+ -- with a child declaration (like a constuctor or type class function)
+ | AugmentChain [Text] ChildInstanceChainInfo
+ -- ^ Augments a declaration with a type class instance chain element.
+ -- A instance declaration with no chain is treated as a chain with one element.
+ -- The first parameter is the `chainId` and consists of the names of the instance declarations.
+ -- `instance a :: ... else instance b :: ...` would have `chainId` `["a", "b"]`
-- | Augment top-level declarations; the second pass. See the comments under
-- the type synonym IntermediateDeclaration for more information.
@@ -78,15 +85,29 @@ augmentDeclarations (partitionEithers -> (augments, toplevels)) =
where
go ds (parentTitles, a) =
map (\d ->
- if any (matches d) parentTitles
- then augmentWith a d
- else d) ds
+ case find (matches d) parentTitles of
+ Just match -> augmentWith match a d
+ Nothing -> d) ds
matches d (name, AugmentType) = isType d && declTitle d == name
matches d (name, AugmentClass) = isTypeClass d && declTitle d == name
- augmentWith (AugmentChild child) d =
+ augmentWith _ (AugmentChild child) d =
d { declChildren = declChildren d ++ [child] }
+ augmentWith (_, AugmentClass) (AugmentChain chainId instanceChainInfo) d =
+ d { declChildren = augmentChildInstance chainId instanceChainInfo (declChildren d) }
+ augmentWith (_, AugmentType) (AugmentChain chainId instanceChainInfo) d =
+ d { declChildren = declChildren d ++ [ChildDeclaration (titleForInstanceChain chainId) Nothing Nothing (ChildPartOfInstanceChain instanceChainInfo)]}
+
+ titleForInstanceChain = T.intercalate "-else-"
+
+ augmentChildInstance chainId instanceChainInfo [] = [ChildDeclaration (titleForInstanceChain chainId) Nothing Nothing (ChildInstanceChain [instanceChainInfo])]
+ augmentChildInstance chainId instanceChainInfo (ChildDeclaration name comment span (ChildInstanceChain chain) : rest) =
+ if titleForInstanceChain chainId == name then
+ (ChildDeclaration name comment span (ChildInstanceChain (chain ++ [instanceChainInfo])) : rest)
+ else
+ (ChildDeclaration name comment span (ChildInstanceChain chain) : augmentChildInstance chainId instanceChainInfo rest)
+ augmentChildInstance chainId instanceChainInfo (a : tail) = a : augmentChildInstance chainId instanceChainInfo tail
getDeclarationTitle :: P.Declaration -> Maybe Text
getDeclarationTitle (P.ValueDeclaration vd) = Just (P.showIdent (P.valdeclIdent vd))
@@ -144,8 +165,8 @@ convertDeclaration (P.TypeClassDeclaration sa _ args implies fundeps ds) title =
ChildDeclaration (P.showIdent ident') (convertComments com) (Just ss) (ChildTypeClassMember (ty $> ()))
convertClassMember _ =
P.internalError "convertDeclaration: Invalid argument to convertClassMember."
-convertDeclaration (P.TypeInstanceDeclaration (ss, com) _ _ _ constraints className tys _) title =
- Just (Left ((classNameString, AugmentClass) : map (, AugmentType) typeNameStrings, AugmentChild childDecl))
+convertDeclaration (P.TypeInstanceDeclaration (ss, com) instanceChain _ _ constraints className tys _) title =
+ Just (Left ((classNameString, AugmentClass) : map (, AugmentType) typeNameStrings, AugmentChain (P.runIdent <$> instanceChain) instanceChainDecl))
where
classNameString = unQual className
typeNameStrings = ordNub (concatMap (P.everythingOnTypes (++) extractProperNames) tys)
@@ -154,7 +175,8 @@ convertDeclaration (P.TypeInstanceDeclaration (ss, com) _ _ _ constraints classN
extractProperNames (P.TypeConstructor _ n) = [unQual n]
extractProperNames _ = []
- childDecl = ChildDeclaration title (convertComments com) (Just ss) (ChildInstance (fmap ($> ()) constraints) (classApp $> ()))
+ instanceChainDecl = ChildInstanceChainInfo title (convertComments com) (Just ss) (fmap ($> ()) constraints) (classApp $> ())
+
classApp = foldl' P.srcTypeApp (P.srcTypeConstructor (fmap P.coerceProperName className)) tys
convertDeclaration (P.ValueFixityDeclaration sa fixity (P.Qualified mn alias) _) title =
Just . Right $ mkDeclaration sa title (AliasDeclaration fixity (P.Qualified mn (Right alias)))
diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs
index 46c2fc7693..52263ef8b5 100644
--- a/src/Language/PureScript/Docs/Render.hs
+++ b/src/Language/PureScript/Docs/Render.hs
@@ -80,20 +80,43 @@ renderDeclaration Declaration{..} =
, aliasName for declTitle
]
-renderChildDeclaration :: ChildDeclaration -> RenderedCode
+data RenderedChildDeclaration
+ = RenderedAsCode RenderedCode
+ | RenderedAsStructure [(ChildInstanceChainInfo, RenderedCode)]
+ deriving (Show, Eq, Ord)
+
+renderChildDeclaration :: ChildDeclaration -> RenderedChildDeclaration
renderChildDeclaration ChildDeclaration{..} =
- mintersperse sp $ case cdeclInfo of
- ChildInstance constraints ty ->
- maybeToList (renderConstraints constraints) ++ [ renderType ty ]
+ case cdeclInfo of
+ ChildInstanceChain instances ->
+ RenderedAsStructure $ intersperseElse (renderInstanceChain <$> instances)
+ ChildPartOfInstanceChain childInstance ->
+ RenderedAsCode $ mintersperse sp $ renderChildInstance childInstance
ChildDataConstructor args ->
- [ dataCtor' cdeclTitle ]
- ++ map renderTypeAtom args
+ RenderedAsCode $ mintersperse sp $
+ [ dataCtor' cdeclTitle ]
+ ++ map renderTypeAtom args
ChildTypeClassMember ty ->
- [ ident' cdeclTitle
- , syntax "::"
- , renderType ty
- ]
+ RenderedAsCode $ mintersperse sp $
+ [ ident' cdeclTitle
+ , syntax "::"
+ , renderType ty
+ ]
+
+ where
+ intersperseElse :: [(a, RenderedCode)] -> [(a, RenderedCode)]
+ intersperseElse = zipWith ($) $ id : repeat (mapSnd $ ((keywordElse <> sp) <>))
+
+ mapSnd f (a, b) = (a, f b)
+
+ renderInstanceChain :: ChildInstanceChainInfo -> (ChildInstanceChainInfo, RenderedCode)
+ renderInstanceChain inst =
+ (inst, mintersperse sp $ renderChildInstance $ inst)
+
+renderChildInstance :: ChildInstanceChainInfo -> [RenderedCode]
+renderChildInstance (ChildInstanceChainInfo{..}) =
+ [ ident' icTitle, syntax "::" ] ++ maybeToList (renderConstraints icConstraint) ++ [ renderType icType ]
renderConstraint :: Constraint' -> RenderedCode
renderConstraint (P.Constraint ann pn kinds tys _) =
diff --git a/src/Language/PureScript/Docs/RenderedCode/Types.hs b/src/Language/PureScript/Docs/RenderedCode/Types.hs
index 8eefbe1ad9..572eeabbd9 100644
--- a/src/Language/PureScript/Docs/RenderedCode/Types.hs
+++ b/src/Language/PureScript/Docs/RenderedCode/Types.hs
@@ -33,6 +33,7 @@ module Language.PureScript.Docs.RenderedCode.Types
, keywordFixity
, keywordKind
, keywordAs
+ , keywordElse
, ident
, dataCtor
, typeCtor
@@ -310,6 +311,9 @@ keywordKind = keyword "kind"
keywordAs :: RenderedCode
keywordAs = keyword "as"
+keywordElse :: RenderedCode
+keywordElse = keyword "else"
+
ident :: Qualified Ident -> RenderedCode
ident (fromQualified -> (mn, name)) =
RC [Symbol ValueLevel (runIdent name) (Link mn)]
diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs
index 1170f0fe20..121ce49ff1 100644
--- a/src/Language/PureScript/Docs/Types.hs
+++ b/src/Language/PureScript/Docs/Types.hs
@@ -278,9 +278,17 @@ instance NFData ChildDeclaration
data ChildDeclarationInfo
-- |
- -- A type instance declaration, with its dependencies and its type.
+ -- A type instance declaration on the type class side.
+ -- For example: `class Data.Either.Inject` would have `[Inject a a, Inject a (Either a b), ...]
--
- = ChildInstance [Constraint'] Type'
+ = ChildInstanceChain [ChildInstanceChainInfo]
+
+ -- |
+ -- A instance declaration on the data-type side.
+ -- For example: `Maybe` would have ChildInstanceChainInfo `Functor Maybe`
+ --
+ | ChildPartOfInstanceChain ChildInstanceChainInfo
+
-- |
-- A data constructor, with its type arguments.
@@ -297,10 +305,23 @@ data ChildDeclarationInfo
instance NFData ChildDeclarationInfo
+data ChildInstanceChainInfo =
+ ChildInstanceChainInfo
+ { icTitle :: Text
+ , icComments :: Maybe Text
+ , icSourceSpan :: Maybe P.SourceSpan
+ , icConstraint :: [Constraint']
+ , icType :: Type'
+ }
+ deriving (Show, Eq, Ord, Generic)
+
+instance NFData ChildInstanceChainInfo
+
childDeclInfoToString :: ChildDeclarationInfo -> Text
-childDeclInfoToString (ChildInstance _ _) = "instance"
-childDeclInfoToString (ChildDataConstructor _) = "dataConstructor"
-childDeclInfoToString (ChildTypeClassMember _) = "typeClassMember"
+childDeclInfoToString (ChildInstanceChain _) = "instanceChain"
+childDeclInfoToString (ChildPartOfInstanceChain _) = "partOfInstanceChain"
+childDeclInfoToString (ChildDataConstructor _) = "dataConstructor"
+childDeclInfoToString (ChildTypeClassMember _) = "typeClassMember"
childDeclInfoNamespace :: ChildDeclarationInfo -> Namespace
childDeclInfoNamespace =
@@ -309,7 +330,9 @@ childDeclInfoNamespace =
-- to update this, instead of having this function (possibly incorrectly)
-- just return ValueLevel for the new constructor.
\case
- ChildInstance{} ->
+ ChildInstanceChain{} ->
+ ValueLevel
+ ChildPartOfInstanceChain{} ->
ValueLevel
ChildDataConstructor{} ->
ValueLevel
@@ -667,8 +690,16 @@ asChildDeclarationInfo = do
ty <- key "declType" asText
case ty of
"instance" ->
- ChildInstance <$> key "dependencies" (eachInArray asConstraint)
- <*> key "type" asType
+ -- This is the legacy case.
+ -- New compilers will generate "instanceChain" and "partofInstanceChain" respectively.
+ -- Old compilers don't expose information about instance chains in the docs.
+ -- Therefore we assume the instance is not part of a chain.
+ ChildInstanceChain . (: []) <$> asChildInstanceInfo
+
+ "instanceChain" ->
+ ChildInstanceChain <$> key "instances" (eachInArray asChildInstanceInfo)
+ "partOfInstanceChain" ->
+ ChildPartOfInstanceChain <$> key "instance" asChildInstanceInfo
"dataConstructor" ->
ChildDataConstructor <$> key "arguments" (eachInArray asType)
"typeClassMember" ->
@@ -676,6 +707,14 @@ asChildDeclarationInfo = do
other ->
throwCustomError $ InvalidChildDeclarationType other
+asChildInstanceInfo :: Parse PackageError ChildInstanceChainInfo
+asChildInstanceInfo = ChildInstanceChainInfo
+ <$> key "title" asText
+ <*> key "comments" (perhaps asText)
+ <*> key "sourceSpan" (perhaps asSourceSpan)
+ <*> key "dependencies" (eachInArray asConstraint)
+ <*> key "type" asType
+
asSourcePos :: Parse e P.SourcePos
asSourcePos = P.SourcePos <$> nth 0 asIntegral
<*> nth 1 asIntegral
@@ -806,10 +845,20 @@ 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]
+ ChildInstanceChain instances -> ["instances" .= instances]
+ ChildPartOfInstanceChain childInstance -> ["instance" .= childInstance]
ChildDataConstructor args -> ["arguments" .= args]
ChildTypeClassMember ty -> ["type" .= ty]
+instance A.ToJSON ChildInstanceChainInfo where
+ toJSON ChildInstanceChainInfo{..} =
+ A.object [ "title" .= icTitle
+ , "comments" .= icComments
+ , "sourceSpan" .= icSourceSpan
+ , "dependencies" .= icConstraint
+ , "type" .= icType
+ ]
+
instance A.ToJSON GithubUser where
toJSON = A.toJSON . runGithubUser