purescript · csicar · Oct 4, 2020 · Oct 4, 2020 · Oct 4, 2020 · Oct 4, 2020
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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,15 +690,31 @@ 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" ->
       ChildTypeClassMember <$> key "type" asType
     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