diff --git a/src/App.elm b/src/App.elm index 41b20b6..cacf0d3 100644 --- a/src/App.elm +++ b/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 ) diff --git a/src/Definition/Reference.elm b/src/Definition/Reference.elm index f0211cf..b285317 100644 --- a/src/Definition/Reference.elm +++ b/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 diff --git a/src/HashQualified.elm b/src/HashQualified.elm index 7e2251a..278911f 100644 --- a/src/HashQualified.elm +++ b/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 diff --git a/src/Perspective.elm b/src/Perspective.elm index b193595..8539542 100644 --- a/src/Perspective.elm +++ b/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 diff --git a/src/Workspace.elm b/src/Workspace.elm index ff1f14d..c57a156 100644 --- a/src/Workspace.elm +++ b/src/Workspace.elm @@ -16,6 +16,7 @@ import Definition.Doc as Doc import Definition.Reference as Reference exposing (Reference) import Env exposing (Env) import FullyQualifiedName exposing (FQN) +import Hash import HashQualified as HQ import Html exposing (Html, article, div, header, section) import Html.Attributes exposing (class, id) @@ -93,31 +94,55 @@ update env msg ({ workspaceItems } as model) = ( model, Cmd.none, ShowFinderRequest Nothing ) FetchItemFinished ref itemResult -> - let - ( workspaceItem, cmd ) = - case itemResult of - Err e -> - ( WorkspaceItem.Failure ref e, Cmd.none ) + case itemResult of + Err e -> + ( { model | workspaceItems = WorkspaceItems.replace workspaceItems ref (WorkspaceItem.Failure ref e) } + , Cmd.none + , None + ) + + Ok i -> + let + cmd = + -- Docs items are always shown in full and never cropped + if WorkspaceItem.isDocItem i then + Cmd.none + + else + isDocCropped ref - Ok i -> + isDupe wi = let - c = - -- Docs items are always shown in full and never cropped - if WorkspaceItem.isDocItem i then - Cmd.none + ref_ = + WorkspaceItem.reference wi - else - isDocCropped ref - in - ( WorkspaceItem.fromItem ref i, c ) + refEqs = + Reference.equals ref ref_ - nextWorkspaceItems = - WorkspaceItems.replace workspaceItems ref workspaceItem - in - ( { model | workspaceItems = nextWorkspaceItems } - , cmd - , None - ) + hashEqs = + wi + |> WorkspaceItem.hash + |> Maybe.map (Hash.equals (WorkspaceItem.itemHash i)) + |> Maybe.withDefault False + in + (Reference.same ref ref_ && not refEqs) || (hashEqs && not refEqs) + + -- In some cases (like using the back button between + -- perspectives) we try and fetch the same item twice, not + -- knowing we've fetched it before since one was by hash + -- and the other by name. If found to already be fetched, + -- we favor the newly fetched item and discard the old + deduped = + workspaceItems + |> WorkspaceItems.find isDupe + |> Maybe.map WorkspaceItem.reference + |> Maybe.map (WorkspaceItems.remove workspaceItems) + |> Maybe.withDefault workspaceItems + + nextWorkspaceItems = + WorkspaceItems.replace deduped ref (WorkspaceItem.fromItem ref i) + in + ( { model | workspaceItems = nextWorkspaceItems }, cmd, None ) IsDocCropped ref res -> let diff --git a/src/Workspace/WorkspaceItem.elm b/src/Workspace/WorkspaceItem.elm index ada9686..4f48b27 100644 --- a/src/Workspace/WorkspaceItem.elm +++ b/src/Workspace/WorkspaceItem.elm @@ -132,10 +132,10 @@ reference item = toHashReference : WorkspaceItem -> WorkspaceItem toHashReference workspaceItem = let - toHashOnly hash hq = + toHashOnly hash_ hq = case hq of HQ.NameOnly _ -> - HQ.HashOnly hash + HQ.HashOnly hash_ HQ.HashOnly h -> HQ.HashOnly h @@ -254,6 +254,26 @@ hasDoc item = False +{-| Attempt to get the Hash of a WorkspaceItem. First by checking if the +Reference includes the Hash, secondly by checking the item data itself. +-} +hash : WorkspaceItem -> Maybe Hash +hash wItem = + let + itemHash_ = + case wItem of + Success _ d -> + Just (itemHash d.item) + + _ -> + Nothing + in + wItem + |> reference + |> Reference.hash + |> MaybeE.orElse itemHash_ + + itemHash : Item -> Hash itemHash item = case item of @@ -387,21 +407,21 @@ viewInfoItems hash_ info = formattedHash = hash_ |> Hash.toShortString |> Hash.stripHashPrefix - hash = + hashTooltip = Tooltip.tooltip (viewInfoItem Icon.hash formattedHash) (Tooltip.Text (Hash.toString hash_)) |> Tooltip.withArrow Tooltip.Start |> Tooltip.view in - div [ class "info-items" ] [ hash, namespace, otherNames ] + div [ class "info-items" ] [ hashTooltip, namespace, otherNames ] viewInfo : Zoom -> Msg -> Hash -> Info -> Category -> Html Msg -viewInfo zoom onClick_ hash info category = +viewInfo zoom onClick_ hash_ info category = div [ class "info" ] [ FoldToggle.foldToggle onClick_ |> FoldToggle.isOpen (zoom /= Far) |> FoldToggle.view , div [ class "category-icon" ] [ Icon.view (Category.icon category) ] , h3 [ class "name" ] [ FQN.view info.name ] - , viewInfoItems hash info + , viewInfoItems hash_ info ] diff --git a/src/Workspace/WorkspaceItems.elm b/src/Workspace/WorkspaceItems.elm index e68f61d..2342321 100644 --- a/src/Workspace/WorkspaceItems.elm +++ b/src/Workspace/WorkspaceItems.elm @@ -18,8 +18,10 @@ module Workspace.WorkspaceItems exposing (..) import Definition.Reference exposing (Reference) +import Hash exposing (Hash) import List import List.Extra as ListE +import Maybe.Extra as MaybeE import Workspace.WorkspaceItem as WorkspaceItem exposing (WorkspaceItem) @@ -253,6 +255,14 @@ member items ref = items |> references |> List.member ref +hashes : WorkspaceItems -> List Hash +hashes items = + items + |> toList + |> List.map WorkspaceItem.hash + |> MaybeE.values + + references : WorkspaceItems -> List Reference references items = items @@ -445,6 +455,27 @@ map f wItems = } +find : (WorkspaceItem -> Bool) -> WorkspaceItems -> Maybe WorkspaceItem +find pred wItems = + wItems + |> toList + |> ListE.find pred + + +all : (WorkspaceItem -> Bool) -> WorkspaceItems -> Bool +all pred wItems = + wItems + |> toList + |> List.all pred + + +any : (WorkspaceItem -> Bool) -> WorkspaceItems -> Bool +any pred wItems = + wItems + |> toList + |> List.any pred + + mapToList : (WorkspaceItem -> Bool -> a) -> WorkspaceItems -> List a mapToList f wItems = case wItems of