Merge pull request #223 from unisonweb/render-readme

Add support for a Namespace Readme

Author: hojberg

src/Api.elm

@@ -5,6 +5,7 @@ module Api exposing
     , find
     , getDefinition
     , list
+    , namespace
     , perform
     , toRequest
     , toUrl
@@ -36,10 +37,19 @@ type Endpoint
 list : PerspectiveParams -> Maybe String -> Endpoint
 list perspectiveParams fqnOrHash =
     let
-        namespace =
+        namespace_ =
             Maybe.withDefault "." fqnOrHash
     in
-    Endpoint [ "list" ] (string "namespace" namespace :: perspectiveParamsToQueryParams perspectiveParams)
+    Endpoint [ "list" ] (string "namespace" namespace_ :: perspectiveParamsToQueryParams perspectiveParams)
+
+
+namespace : Perspective -> FQN -> Endpoint
+namespace perspective fqn =
+    let
+        queryParams =
+            [ rootBranch (Perspective.codebaseHash perspective) ]
+    in
+    Endpoint [ "namespaces", FQN.toString fqn ] queryParams
 
 
 getDefinition : Perspective -> List String -> Endpoint

src/App.elm

@@ -16,7 +16,10 @@ import Http
 import KeyboardShortcut
 import KeyboardShortcut.Key as Key exposing (Key(..))
 import KeyboardShortcut.KeyboardEvent as KeyboardEvent exposing (KeyboardEvent)
+import Namespace exposing (NamespaceDetails)
 import Perspective exposing (Perspective(..))
+import PerspectiveLanding
+import RemoteData
 import Route exposing (Route)
 import UI
 import UI.Button as Button
@@ -44,11 +47,13 @@ type alias Model =
     , route : Route
     , codebaseTree : CodebaseTree.Model
     , workspace : Workspace.Model
+    , perspectiveLanding : PerspectiveLanding.Model
     , modal : Modal
     , keyboardShortcut : KeyboardShortcut.Model
     , env : Env
 
-    -- This is called "toggled" and not "hidden" because the behavior if toggling the sidebar on/off is inverse on mobile vs desktop
+    -- This is called "toggled" and not "hidden" because the behavior of
+    -- toggling the sidebar on/off is inverse on mobile vs desktop
     , sidebarToggled : Bool
     }
 
@@ -67,10 +72,17 @@ init env route navKey =
         ( codebaseTree, codebaseTreeCmd ) =
             CodebaseTree.init env
 
+        fetchNamespaceDetailsCmd =
+            env.perspective
+                |> fetchNamespaceDetails
+                |> Maybe.map (Api.perform env.apiBasePath)
+                |> Maybe.withDefault Cmd.none
+
         model =
             { navKey = navKey
             , route = route
             , workspace = workspace
+            , perspectiveLanding = PerspectiveLanding.init
             , codebaseTree = codebaseTree
             , modal = NoModal
             , keyboardShortcut = KeyboardShortcut.init env.operatingSystem
@@ -82,6 +94,7 @@ init env route navKey =
     , Cmd.batch
         [ Cmd.map CodebaseTreeMsg codebaseTreeCmd
         , Cmd.map WorkspaceMsg workspaceCmd
+        , fetchNamespaceDetailsCmd
         ]
     )
 
@@ -94,6 +107,7 @@ type Msg
     = LinkClicked Browser.UrlRequest
     | UrlChanged Url
     | ChangePerspective Perspective
+    | FetchPerspectiveNamespaceDetailsFinished FQN (Result Http.Error NamespaceDetails)
     | Keydown KeyboardEvent
     | OpenDefinition Reference
     | ShowModal Modal
@@ -102,6 +116,7 @@ type Msg
       -- sub msgs
     | FinderMsg Finder.Msg
     | WorkspaceMsg Workspace.Msg
+    | PerspectiveLandingMsg PerspectiveLanding.Msg
     | CodebaseTreeMsg CodebaseTree.Msg
     | KeyboardShortcutMsg KeyboardShortcut.Msg
 
@@ -121,6 +136,25 @@ update msg ({ env } as model) =
         ChangePerspective perspective ->
             replacePerspective model perspective
 
+        FetchPerspectiveNamespaceDetailsFinished fqn details ->
+            let
+                perspective =
+                    case env.perspective of
+                        Namespace p ->
+                            if FQN.equals p.fqn fqn then
+                                Namespace { p | details = RemoteData.fromResult details }
+
+                            else
+                                env.perspective
+
+                        _ ->
+                            env.perspective
+
+                nextEnv =
+                    { env | perspective = perspective }
+            in
+            ( { model | env = nextEnv }, Cmd.none )
+
         Keydown event ->
             keydown model event
 
@@ -150,6 +184,24 @@ update msg ({ env } as model) =
             in
             ( model3, Cmd.batch [ cmd, Cmd.map WorkspaceMsg wCmd ] )
 
+        PerspectiveLandingMsg rMsg ->
+            let
+                ( perspectiveLanding, outMsg ) =
+                    PerspectiveLanding.update rMsg model.perspectiveLanding
+
+                model2 =
+                    { model | perspectiveLanding = perspectiveLanding }
+            in
+            case outMsg of
+                PerspectiveLanding.OpenDefinition ref ->
+                    openDefinition model2 ref
+
+                PerspectiveLanding.ShowFinderRequest ->
+                    showFinder model2 Nothing
+
+                PerspectiveLanding.None ->
+                    ( model2, Cmd.none )
+
         CodebaseTreeMsg cMsg ->
             let
                 ( codebaseTree, cCmd, outMsg ) =
@@ -231,9 +283,19 @@ replacePerspective ({ env } as model) perspective =
 
         changeRouteCmd =
             Route.replacePerspective model.navKey (Perspective.toParams perspective) model.route
+
+        fetchNamespaceDetailsCmd =
+            perspective
+                |> fetchNamespaceDetails
+                |> Maybe.map (Api.perform env.apiBasePath)
+                |> Maybe.withDefault Cmd.none
     in
     ( { model | env = newEnv, codebaseTree = codebaseTree }
-    , Cmd.batch [ Cmd.map CodebaseTreeMsg codebaseTreeCmd, changeRouteCmd ]
+    , Cmd.batch
+        [ Cmd.map CodebaseTreeMsg codebaseTreeCmd
+        , changeRouteCmd
+        , fetchNamespaceDetailsCmd
+        ]
     )
 
 
@@ -310,6 +372,27 @@ showFinder model withinNamespace =
     ( { model | modal = FinderModal fm }, Cmd.map FinderMsg fcmd )
 
 
+
+-- EFFECTS
+
+
+fetchNamespaceDetails : Perspective -> Maybe (Api.ApiRequest NamespaceDetails Msg)
+fetchNamespaceDetails perspective =
+    case perspective of
+        Namespace { fqn } ->
+            fqn
+                |> Api.namespace perspective
+                |> Api.toRequest Namespace.decodeDetails (FetchPerspectiveNamespaceDetailsFinished fqn)
+                |> Just
+
+        _ ->
+            Nothing
+
+
+
+-- SUBSCRIPTIONS
+
+
 subscriptions : Model -> Sub Msg
 subscriptions model =
     Sub.batch
@@ -609,13 +692,25 @@ view model =
 
                 Ucm ->
                     "Unison Local"
+
+        page =
+            case model.route of
+                Route.Perspective _ ->
+                    Html.map PerspectiveLandingMsg
+                        (PerspectiveLanding.view
+                            model.env
+                            model.perspectiveLanding
+                        )
+
+                Route.Definition _ _ ->
+                    Html.map WorkspaceMsg (Workspace.view model.workspace)
     in
     { title = title_
     , body =
         [ div [ id "app", classList [ ( "sidebar-toggled", model.sidebarToggled ) ] ]
             [ viewMainHeader model
             , viewMainSidebar model
-            , div [ id "main-content" ] [ Html.map WorkspaceMsg (Workspace.view model.env model.workspace) ]
+            , div [ id "main-content" ] [ page ]
             , viewModal model
             ]
         ]

src/Definition/Readme.elm

@@ -0,0 +1,42 @@
+module Definition.Readme exposing (..)
+
+import Definition.Doc as Doc exposing (Doc, DocFoldToggles, FoldId)
+import Definition.Reference exposing (Reference)
+import Html exposing (Html, div, header, text)
+import Html.Attributes exposing (class)
+import Json.Decode as Decode
+import UI.Icon as Icon
+
+
+{-| Represent the Readme Doc definition of a namespace. This is typically
+rendered slightly different than other docs when viewed from a Namespace
+landing page point of view.
+-}
+type Readme
+    = Readme Doc
+
+
+
+-- VIEW
+
+
+view :
+    (Reference -> msg)
+    -> (FoldId -> msg)
+    -> DocFoldToggles
+    -> Readme
+    -> Html msg
+view refToMsg toggleFoldMsg docFoldToggles (Readme doc) =
+    div [ class "readme" ]
+        [ header [] [ Icon.view Icon.doc, text "README" ]
+        , Doc.view refToMsg toggleFoldMsg docFoldToggles doc
+        ]
+
+
+
+-- DECODE
+
+
+decode : Decode.Decoder Readme
+decode =
+    Decode.map Readme Doc.decode

src/Namespace.elm

@@ -0,0 +1,53 @@
+module Namespace exposing (..)
+
+import Definition.Readme as Readme exposing (Readme)
+import FullyQualifiedName as FQN exposing (FQN)
+import Hash exposing (Hash)
+import Json.Decode as Decode exposing (field, maybe)
+
+
+type Namespace a
+    = Namespace FQN Hash a
+
+
+type alias NamespaceDetailsFields =
+    { readme : Maybe Readme }
+
+
+type alias NamespaceDetails =
+    Namespace NamespaceDetailsFields
+
+
+
+-- Helpers --------------------------------------------------------------------
+
+
+fqn : Namespace a -> FQN
+fqn (Namespace fqn_ _ _) =
+    fqn_
+
+
+hash : Namespace a -> Hash
+hash (Namespace _ h _) =
+    h
+
+
+readme : NamespaceDetails -> Maybe Readme
+readme (Namespace _ _ details) =
+    details.readme
+
+
+
+-- Decode ---------------------------------------------------------------------
+
+
+decodeDetails : Decode.Decoder NamespaceDetails
+decodeDetails =
+    let
+        makeDetails fqn_ hash_ readme_ =
+            Namespace fqn_ hash_ { readme = readme_ }
+    in
+    Decode.map3 makeDetails
+        (field "fqn" FQN.decode)
+        (field "hash" Hash.decode)
+        (maybe (field "readme" Readme.decode))

src/Perspective.elm

@@ -3,16 +3,22 @@ module Perspective exposing (..)
 import FullyQualifiedName as FQN exposing (FQN)
 import Hash exposing (Hash)
 import Json.Decode as Decode exposing (field)
+import Namespace exposing (NamespaceDetails)
+import RemoteData exposing (RemoteData(..), WebData)
 
 
 type Perspective
     = Codebase Hash
-    | Namespace { codebaseHash : Hash, fqn : FQN }
+    | Namespace
+        { codebaseHash : Hash
+        , fqn : FQN
+        , details : WebData NamespaceDetails
+        }
 
 
 toNamespacePerspective : Perspective -> FQN -> Perspective
 toNamespacePerspective perspective fqn_ =
-    Namespace { codebaseHash = codebaseHash perspective, fqn = fqn_ }
+    Namespace { codebaseHash = codebaseHash perspective, fqn = fqn_, details = NotAsked }
 
 
 codebaseHash : Perspective -> Hash
@@ -58,7 +64,7 @@ fromParams params =
             Just (Codebase h)
 
         ByNamespace (Absolute h) fqn_ ->
-            Just (Namespace { codebaseHash = h, fqn = fqn_ })
+            Just (Namespace { codebaseHash = h, fqn = fqn_, details = NotAsked })
 
 
 
@@ -74,7 +80,7 @@ decode perspectiveParams =
                     Codebase codebaseHash_
 
                 ByNamespace _ fqn_ ->
-                    Namespace { codebaseHash = codebaseHash_, fqn = fqn_ }
+                    Namespace { codebaseHash = codebaseHash_, fqn = fqn_, details = NotAsked }
     in
     Decode.map make (field "namespaceListingHash" Hash.decode)