Add download button near perspective and modal

Add a new download button near the perspective details that when clicked
shows a new download modal with `pull` instructions and a command copy
field. This button only shows up on Unison Share.

The copy field uses a webcomponent to reach out from Elm into JS and
access the clipboard.

The download command being generated also uncovered a problem with the
way FQNs were being deserialized, such that they'd always include a .
prefix. This lead to some strange URLs and didn't buy us anything and
was removed.

Author: hojberg

src/Api.elm

@@ -33,9 +33,13 @@ type Endpoint
     = Endpoint (List String) (List QueryParameter)
 
 
-list : PerspectiveParams -> String -> Endpoint
+list : PerspectiveParams -> Maybe String -> Endpoint
 list perspectiveParams fqnOrHash =
-    Endpoint [ "list" ] (string "namespace" fqnOrHash :: perspectiveParamsToQueryParams perspectiveParams)
+    let
+        namespace =
+            Maybe.withDefault "." fqnOrHash
+    in
+    Endpoint [ "list" ] (string "namespace" namespace :: perspectiveParamsToQueryParams perspectiveParams)
 
 
 getDefinition : Perspective -> List String -> Endpoint

src/App.elm

@@ -7,7 +7,7 @@ import CodebaseTree
 import Definition.Reference exposing (Reference(..))
 import Env as Env exposing (AppContext(..), Env, OperatingSystem(..))
 import Finder
-import FullyQualifiedName as FQN
+import FullyQualifiedName as FQN exposing (FQN)
 import HashQualified exposing (HashQualified(..))
 import Html exposing (Html, a, aside, div, h1, h2, h3, header, nav, p, section, span, strong, text)
 import Html.Attributes exposing (class, classList, href, id, rel, target, title)
@@ -21,6 +21,7 @@ import RemoteData exposing (RemoteData(..))
 import Route exposing (Route)
 import UI
 import UI.Button as Button
+import UI.CopyField as CopyField
 import UI.Icon as Icon
 import UI.Modal as Modal
 import UI.Tooltip as Tooltip
@@ -38,6 +39,7 @@ type Modal
     | HelpModal
     | ReportBugModal
     | PublishModal
+    | DownloadModal FQN
 
 
 type alias Model =
@@ -385,16 +387,30 @@ viewPerspective env =
 
                 back =
                     Tooltip.tooltip
-                        (Button.icon (ChangePerspective (Codebase codebaseHash)) Icon.arrowLeftUp |> Button.small |> Button.view)
+                        (Button.icon (ChangePerspective (Codebase codebaseHash)) Icon.arrowLeftUp |> Button.small |> Button.uncontained |> Button.view)
                         (Tooltip.Text ("You're currently viewing a subset of " ++ context ++ " (" ++ fqnText ++ "), click to view everything."))
                         |> Tooltip.withArrow Tooltip.End
                         |> Tooltip.view
+
+                download =
+                    case env.appContext of
+                        UnisonShare ->
+                            Button.iconThenLabel (ShowModal (DownloadModal fqn)) Icon.download "Download latest version"
+                                |> Button.small
+                                |> Button.view
+
+                        Ucm ->
+                            UI.nothing
             in
             header
                 [ class "perspective" ]
-                [ div [ class "namespace-slug" ] []
-                , h2 [] [ text fqnText ]
-                , back
+                [ div [ class "perspective-row" ]
+                    [ div [ class "namespace-slug" ] []
+                    , h2 [] [ text fqnText ]
+                    , back
+                    ]
+                , div [ class "perspective-row" ] [ download ]
+                , UI.divider
                 ]
 
 
@@ -488,7 +504,10 @@ viewHelpModal os keyboardShortcut =
 
 githubLinkButton : String -> Html msg
 githubLinkButton repo =
-    Button.linkIconThenLabel ("https://github.com/" ++ repo) Icon.github repo |> Button.small |> Button.view
+    Button.linkIconThenLabel ("https://github.com/" ++ repo) Icon.github repo
+        |> Button.small
+        |> Button.contained
+        |> Button.view
 
 
 viewPublishModal : Html Msg
@@ -546,6 +565,33 @@ viewReportBugModal appContext =
         |> Modal.view
 
 
+viewDownloadModal : FQN -> Html Msg
+viewDownloadModal fqn =
+    let
+        prettyName =
+            FQN.toString fqn
+
+        unqualified =
+            FQN.unqualifiedName fqn
+
+        pullCommand =
+            "pull [email protected]:unisonweb/share.git:." ++ prettyName ++ " ." ++ unqualified
+
+        content =
+            Modal.Content
+                (section
+                    []
+                    [ p [] [ text "Download ", UI.bold prettyName, text " by pulling the namespace from Unison Share into a namespace in your local codebase:" ]
+                    , CopyField.copyField (\_ -> CloseModal) pullCommand |> CopyField.withPrefix ".>" |> CopyField.view
+                    , div [ class "hint" ] [ text "Copy and paste this command into UCM." ]
+                    ]
+                )
+    in
+    Modal.modal "download-modal" CloseModal content
+        |> Modal.withHeader ("Download " ++ prettyName)
+        |> Modal.view
+
+
 viewModal :
     { m | env : Env, modal : Modal, keyboardShortcut : KeyboardShortcut.Model }
     -> Html Msg
@@ -566,6 +612,9 @@ viewModal model =
         ReportBugModal ->
             viewReportBugModal model.env.appContext
 
+        DownloadModal fqn ->
+            viewDownloadModal fqn
+
 
 viewAppLoading : AppContext -> Html msg
 viewAppLoading appContext =

src/CodebaseTree.elm

@@ -8,6 +8,7 @@ import CodebaseTree.NamespaceListing as NamespaceListing
         , NamespaceListingChild(..)
         , NamespaceListingContent
         )
+import Debug
 import Definition.Category as Category
 import Definition.Reference exposing (Reference(..))
 import Env exposing (Env)
@@ -144,21 +145,17 @@ update env msg model =
 
 fetchRootNamespaceListing : Perspective -> ApiRequest NamespaceListing Msg
 fetchRootNamespaceListing perspective =
-    let
-        rootFqn =
-            FQN.fromString "."
-    in
-    fetchNamespaceListing perspective rootFqn FetchRootNamespaceListingFinished
+    fetchNamespaceListing perspective Nothing FetchRootNamespaceListingFinished
 
 
 fetchSubNamespaceListing : Perspective -> FQN -> ApiRequest NamespaceListing Msg
 fetchSubNamespaceListing perspective fqn =
-    fetchNamespaceListing perspective fqn (FetchSubNamespaceListingFinished fqn)
+    fetchNamespaceListing perspective (Just fqn) (FetchSubNamespaceListingFinished fqn)
 
 
-fetchNamespaceListing : Perspective -> FQN -> (Result Http.Error NamespaceListing -> msg) -> ApiRequest NamespaceListing msg
+fetchNamespaceListing : Perspective -> Maybe FQN -> (Result Http.Error NamespaceListing -> msg) -> ApiRequest NamespaceListing msg
 fetchNamespaceListing perspective fqn toMsg =
-    Api.list (Perspective.toParams perspective) (FQN.toString fqn)
+    Api.list (Perspective.toParams perspective) (Maybe.map FQN.toString fqn)
         |> Api.toRequest (NamespaceListing.decode fqn) toMsg
 
 
@@ -266,6 +263,9 @@ viewNamespaceListing expandedNamespaceListings (NamespaceListing _ fqn content)
 
         fullName =
             FQN.toString fqn
+
+        log =
+            Debug.log "fqn" fqn
     in
     div [ class "subtree" ]
         [ a

src/CodebaseTree/NamespaceListing.elm

@@ -8,9 +8,7 @@ module CodebaseTree.NamespaceListing exposing
     , map
     )
 
-import Definition.AbilityConstructor as AbilityConstructor
 import Definition.Category as Category exposing (Category)
-import Definition.DataConstructor as DataConstructor
 import Definition.Term as Term exposing (TermCategory(..))
 import Definition.Type as Type exposing (TypeCategory(..))
 import FullyQualifiedName as FQN exposing (FQN)
@@ -80,7 +78,7 @@ contentFetched (NamespaceListing _ fqn content) needleFqn =
 -- JSON DECODE
 
 
-decode : FQN -> Decode.Decoder NamespaceListing
+decode : Maybe FQN -> Decode.Decoder NamespaceListing
 decode listingFqn =
     Decode.map3
         NamespaceListing
@@ -99,24 +97,34 @@ decode listingFqn =
 -- JSON Decode Helpers
 
 
+decodeFromParent : Maybe FQN -> Decode.Decoder FQN
+decodeFromParent parentFqn =
+    parentFqn
+        |> Maybe.map FQN.decodeFromParent
+        |> Maybe.withDefault FQN.decode
+
+
 {-| Decoding specific intermediate type |
 -}
-decodeSubNamespace : FQN -> Decode.Decoder NamespaceListingChild
+decodeSubNamespace : Maybe FQN -> Decode.Decoder NamespaceListingChild
 decodeSubNamespace parentFqn =
     Decode.map SubNamespace
         (Decode.map3 NamespaceListing
             (field "namespaceHash" Hash.decode)
-            (field "namespaceName" (FQN.decodeFromParent parentFqn))
+            (field "namespaceName" (decodeFromParent parentFqn))
             (Decode.succeed NotAsked)
         )
 
 
-decodeContent : FQN -> Decode.Decoder NamespaceListingContent
+decodeContent : Maybe FQN -> Decode.Decoder NamespaceListingContent
 decodeContent parentFqn =
     let
         decodeTag =
             field "tag" Decode.string
 
+        decodeFqn =
+            decodeFromParent parentFqn
+
         termTypeByHash hash =
             if Hash.isAbilityConstructorHash hash then
                 "AbilityConstructor"
@@ -134,29 +142,29 @@ decodeContent parentFqn =
             Decode.map SubDefinition
                 (Decode.map2 AbilityConstructorListing
                     (field "termHash" Hash.decode)
-                    (field "termName" (FQN.decodeFromParent parentFqn))
+                    (field "termName" decodeFqn)
                 )
 
         decodeDataConstructorListing =
             Decode.map SubDefinition
                 (Decode.map2 DataConstructorListing
                     (field "termHash" Hash.decode)
-                    (field "termName" (FQN.decodeFromParent parentFqn))
+                    (field "termName" decodeFqn)
                 )
 
         decodeTypeListing =
             Decode.map SubDefinition
                 (Decode.map3 TypeListing
                     (field "typeHash" Hash.decode)
-                    (field "typeName" (FQN.decodeFromParent parentFqn))
+                    (field "typeName" decodeFqn)
                     (Decode.map Category.Type (Type.decodeTypeCategory [ "typeTag" ]))
                 )
 
         decodeTermListing =
             Decode.map SubDefinition
                 (Decode.map3 TermListing
                     (field "termHash" Hash.decode)
-                    (field "termName" (FQN.decodeFromParent parentFqn))
+                    (field "termName" decodeFqn)
                     (Decode.map Category.Term (Term.decodeTermCategory [ "termTag" ]))
                 )
 

src/PreApp.elm

@@ -5,12 +5,10 @@ import App
 import Browser
 import Browser.Navigation as Nav
 import Env exposing (AppContext(..), Flags, OperatingSystem(..))
-import Html exposing (div, p, text)
-import Html.Attributes exposing (class, id, title)
+import Html
 import Http
 import Perspective exposing (CodebasePerspectiveParam(..), Perspective(..), PerspectiveParams(..))
 import Route exposing (Route)
-import UI.Icon as Icon
 import Url exposing (Url)
 
 
@@ -65,7 +63,7 @@ init flags url navKey =
 
 fetchPerspective : PreEnv -> ApiRequest Perspective Msg
 fetchPerspective preEnv =
-    Api.list (ByCodebase Relative) "."
+    Api.list (ByCodebase Relative) (Just ".")
         |> Api.toRequest (Perspective.decode preEnv.perspectiveParams) (FetchPerspectiveFinished preEnv)
 
 

src/UI.elm

@@ -1,9 +1,14 @@
 module UI exposing (..)
 
-import Html exposing (Attribute, Html, code, div, hr, pre, span, text)
+import Html exposing (Attribute, Html, code, div, hr, pre, span, strong, text)
 import Html.Attributes exposing (class)
 
 
+bold : String -> Html msg
+bold text_ =
+    strong [] [ text text_ ]
+
+
 codeBlock : List (Attribute msg) -> Html msg -> Html msg
 codeBlock attrs code_ =
     pre attrs [ code [] [ code_ ] ]

src/UI/Button.elm

@@ -129,30 +129,21 @@ view { content, type_, color, action, size } =
 
                 Label l ->
                     ( "content-label", [ text l ] )
+
+        attrs =
+            [ class "button"
+            , class (typeToClassName type_)
+            , class (colorToClassName color)
+            , class (sizeToClassName size)
+            , class contentType
+            ]
     in
     case action of
         OnClick clickMsg ->
-            Html.button
-                [ class "button"
-                , class (typeToClassName type_)
-                , class (colorToClassName color)
-                , class (sizeToClassName size)
-                , class contentType
-                , onClick clickMsg
-                ]
-                content_
+            Html.button (onClick clickMsg :: attrs) content_
 
         Href url ->
-            a
-                [ class "button"
-                , class (typeToClassName type_)
-                , class (sizeToClassName size)
-                , class contentType
-                , href url
-                , rel "noopener"
-                , target "_blank"
-                ]
-                content_
+            a (attrs ++ [ href url, rel "noopener", target "_blank" ]) content_