Drive perspective changes off of Route changes

src/App.elm

@@ -140,20 +140,32 @@ update msg ({ env } as model) =
             let
                 route =
                     Route.fromUrl env.basePath url
+
+                model2 =
+                    { model | route = route }
+
+                newEnv params =
+                    { env | perspective = Perspective.nextFromParams env.perspective params }
             in
             case route of
-                Route.Definition _ ref ->
+                Route.Definition params ref ->
                     let
                         ( workspace, cmd ) =
-                            Workspace.open env model.workspace ref
+                            Workspace.open (newEnv params) model.workspace ref
+
+                        model3 =
+                            { model2 | workspace = workspace, env = newEnv params }
+
+                        ( model4, fetchPerspectiveCmd ) =
+                            fetchPerspective model3
                     in
-                    ( { model | route = route, workspace = workspace }, Cmd.map WorkspaceMsg cmd )
+                    ( model4, Cmd.batch [ Cmd.map WorkspaceMsg cmd, fetchPerspectiveCmd ] )
 
-                _ ->
-                    ( { model | route = route }, Cmd.none )
+                Route.Perspective params ->
+                    fetchPerspective { model2 | env = newEnv params }
 
         ChangePerspective perspective ->
-            replacePerspective model perspective
+            navigateToPerspective model perspective
 
         FetchPerspectiveNamespaceDetailsFinished fqn details ->
             let
@@ -245,7 +257,7 @@ update msg ({ env } as model) =
                         CodebaseTree.ChangePerspectiveToNamespace fqn ->
                             fqn
                                 |> Perspective.toNamespacePerspective model.env.perspective
-                                |> replacePerspective model
+                                |> navigateToPerspective model
             in
             ( model3, Cmd.batch [ cmd, Cmd.map CodebaseTreeMsg cCmd ] )
 
@@ -286,15 +298,9 @@ navigateToDefinition model ref =
     ( model, Route.navigateToDefinition model.navKey model.route ref )
 
 
-replacePerspective : Model -> Perspective -> ( Model, Cmd Msg )
-replacePerspective ({ env } as model) perspective =
+navigateToPerspective : Model -> Perspective -> ( Model, Cmd Msg )
+navigateToPerspective model perspective =
     let
-        newEnv =
-            { env | perspective = perspective }
-
-        ( codebaseTree, codebaseTreeCmd ) =
-            CodebaseTree.init newEnv
-
         -- Update all open references to be hash based to ensure that we can
         -- refresh the page and fetch them appropriately even if they are
         -- outside of the current perspective
@@ -310,20 +316,32 @@ replacePerspective ({ env } as model) perspective =
 
         changeRouteCmd =
             Route.replacePerspective model.navKey (Perspective.toParams perspective) focusedReferenceRoute
+    in
+    ( { model | workspace = workspace }, changeRouteCmd )
+
+
+fetchPerspective : Model -> ( Model, Cmd Msg )
+fetchPerspective ({ env } as model) =
+    let
+        ( codebaseTree, codebaseTreeCmd ) =
+            CodebaseTree.init env
 
         fetchNamespaceDetailsCmd =
-            perspective
+            env.perspective
                 |> fetchNamespaceDetails
                 |> Maybe.map (Api.perform env.apiBasePath)
                 |> Maybe.withDefault Cmd.none
     in
-    ( { model | env = newEnv, codebaseTree = codebaseTree, workspace = workspace }
-    , Cmd.batch
-        [ Cmd.map CodebaseTreeMsg codebaseTreeCmd
-        , changeRouteCmd
-        , fetchNamespaceDetailsCmd
-        ]
-    )
+    if Perspective.needsFetching env.perspective then
+        ( { model | codebaseTree = codebaseTree }
+        , Cmd.batch
+            [ Cmd.map CodebaseTreeMsg codebaseTreeCmd
+            , fetchNamespaceDetailsCmd
+            ]
+        )
+
+    else
+        ( model, Cmd.none )
 
 
 handleWorkspaceOutMsg : Model -> Workspace.OutMsg -> ( Model, Cmd Msg )
@@ -344,7 +362,7 @@ handleWorkspaceOutMsg model out =
         Workspace.ChangePerspectiveToNamespace fqn ->
             fqn
                 |> Perspective.toNamespacePerspective model.env.perspective
-                |> replacePerspective model
+                |> navigateToPerspective model
 
 
 keydown : Model -> KeyboardEvent -> ( Model, Cmd Msg )

src/Definition/Reference.elm

@@ -1,6 +1,7 @@
 module Definition.Reference exposing (..)
 
 import FullyQualifiedName exposing (FQN)
+import Hash exposing (Hash)
 import HashQualified as HQ exposing (HashQualified)
 import UI.Icon as Icon exposing (Icon)
 import Url.Parser
@@ -36,6 +37,47 @@ urlParser toRef =
 -- HELPERS
 
 
+equals : Reference -> Reference -> Bool
+equals a b =
+    case ( a, b ) of
+        ( TermReference aHq, TermReference bHq ) ->
+            HQ.equals aHq bHq
+
+        ( TypeReference aHq, TypeReference bHq ) ->
+            HQ.equals aHq bHq
+
+        ( AbilityConstructorReference aHq, AbilityConstructorReference bHq ) ->
+            HQ.equals aHq bHq
+
+        ( DataConstructorReference aHq, DataConstructorReference bHq ) ->
+            HQ.equals aHq bHq
+
+        _ ->
+            False
+
+
+{-| Like `equals`, but compares deeper such that a HashQualified with the same
+Hash as a HashOnly are considered the same
+-}
+same : Reference -> Reference -> Bool
+same a b =
+    case ( a, b ) of
+        ( TermReference aHq, TermReference bHq ) ->
+            HQ.same aHq bHq
+
+        ( TypeReference aHq, TypeReference bHq ) ->
+            HQ.same aHq bHq
+
+        ( AbilityConstructorReference aHq, AbilityConstructorReference bHq ) ->
+            HQ.same aHq bHq
+
+        ( DataConstructorReference aHq, DataConstructorReference bHq ) ->
+            HQ.same aHq bHq
+
+        _ ->
+            False
+
+
 hashQualified : Reference -> HashQualified
 hashQualified ref =
     case ref of
@@ -57,6 +99,11 @@ fqn =
     hashQualified >> HQ.name
 
 
+hash : Reference -> Maybe Hash
+hash =
+    hashQualified >> HQ.hash
+
+
 
 -- TRANSFORM
 

src/HashQualified.elm

@@ -1,9 +1,11 @@
 module HashQualified exposing
     ( HashQualified(..)
+    , equals
     , fromString
     , fromUrlString
     , hash
     , name
+    , same
     , toString
     , toUrlString
     , urlParser
@@ -77,6 +79,54 @@ urlParser =
 -- HELPERS
 
 
+equals : HashQualified -> HashQualified -> Bool
+equals a b =
+    case ( a, b ) of
+        ( NameOnly aFqn, NameOnly bFqn ) ->
+            FQN.equals aFqn bFqn
+
+        ( HashOnly aH, HashOnly bH ) ->
+            Hash.equals aH bH
+
+        ( HashQualified aFqn aH, HashQualified bFqn bH ) ->
+            FQN.equals aFqn bFqn && Hash.equals aH bH
+
+        _ ->
+            False
+
+
+{-| Like `equals`, but compares deeper such that a HashQualified with the same
+Hash as a HashOnly are considered the same, and HashQualified with the same FQN
+as a NameOnly are considered the same.
+-}
+same : HashQualified -> HashQualified -> Bool
+same a b =
+    case ( a, b ) of
+        ( NameOnly aFqn, NameOnly bFqn ) ->
+            FQN.equals aFqn bFqn
+
+        ( HashOnly aH, HashOnly bH ) ->
+            Hash.equals aH bH
+
+        ( HashQualified aFqn aH, HashQualified bFqn bH ) ->
+            FQN.equals aFqn bFqn && Hash.equals aH bH
+
+        ( HashQualified _ aH, HashOnly bH ) ->
+            Hash.equals aH bH
+
+        ( HashOnly aH, HashQualified _ bH ) ->
+            Hash.equals aH bH
+
+        ( HashQualified aFqn _, NameOnly bFqn ) ->
+            FQN.equals aFqn bFqn
+
+        ( NameOnly aFqn, HashQualified bFqn _ ) ->
+            FQN.equals aFqn bFqn
+
+        _ ->
+            False
+
+
 name : HashQualified -> Maybe FQN
 name hq =
     case hq of

src/Perspective.elm

@@ -46,6 +46,19 @@ fqn perspective =
             d.fqn
 
 
+equals : Perspective -> Perspective -> Bool
+equals a b =
+    case ( a, b ) of
+        ( Codebase ah, Codebase bh ) ->
+            Hash.equals ah bh
+
+        ( Namespace ans, Namespace bns ) ->
+            Hash.equals ans.codebaseHash bns.codebaseHash && FQN.equals ans.fqn bns.fqn
+
+        _ ->
+            False
+
+
 {-| Even when we have a Codebase hash, we always constructor Relative params.
 Absolute is currently not supported (until Unison Share includes historic
 codebase), though the model allows it.
@@ -76,6 +89,53 @@ fromParams params =
             Just (Namespace { codebaseHash = h, fqn = fqn_, details = NotAsked })
 
 
+{-| Similar to `fromParams`, but requires a previous `Perspective` (with a
+codebase hash) to migrate from
+-}
+nextFromParams : Perspective -> PerspectiveParams -> Perspective
+nextFromParams perspective params =
+    let
+        codebaseHash_ =
+            codebaseHash perspective
+    in
+    case ( params, perspective ) of
+        ( ByNamespace Relative fqn_, Namespace d ) ->
+            if Hash.equals codebaseHash_ d.codebaseHash && FQN.equals fqn_ d.fqn then
+                Namespace d
+
+            else
+                Namespace { codebaseHash = codebaseHash_, fqn = fqn_, details = NotAsked }
+
+        ( ByNamespace (Absolute h) fqn_, Namespace d ) ->
+            if Hash.equals h d.codebaseHash && FQN.equals fqn_ d.fqn then
+                Namespace d
+
+            else
+                Namespace { codebaseHash = h, fqn = fqn_, details = NotAsked }
+
+        ( ByNamespace Relative fqn_, _ ) ->
+            Namespace { codebaseHash = codebaseHash_, fqn = fqn_, details = NotAsked }
+
+        ( ByNamespace (Absolute h) fqn_, _ ) ->
+            Namespace { codebaseHash = h, fqn = fqn_, details = NotAsked }
+
+        ( ByCodebase Relative, _ ) ->
+            Codebase codebaseHash_
+
+        ( ByCodebase (Absolute h), _ ) ->
+            Codebase h
+
+
+needsFetching : Perspective -> Bool
+needsFetching perspective =
+    case perspective of
+        Namespace d ->
+            d.details == NotAsked
+
+        _ ->
+            False
+
+
 isCodebasePerspective : Perspective -> Bool
 isCodebasePerspective perspective =
     case perspective of