diff --git a/src/Code/Definition/AbilityConstructor.elm b/src/Code/Definition/AbilityConstructor.elm index e1f6d0ba..4dc4b5a1 100644 --- a/src/Code/Definition/AbilityConstructor.elm +++ b/src/Code/Definition/AbilityConstructor.elm @@ -27,7 +27,7 @@ type AbilityConstructor a type alias AbilityConstructorDetail = - AbilityConstructor { info : Info, source : TypeSource } + AbilityConstructor { info : Info, source : TypeSource, signature : TermSignature } type alias AbilityConstructorSummary = diff --git a/src/Code/Definition/DataConstructor.elm b/src/Code/Definition/DataConstructor.elm index 42061f48..786d998d 100644 --- a/src/Code/Definition/DataConstructor.elm +++ b/src/Code/Definition/DataConstructor.elm @@ -27,7 +27,7 @@ type DataConstructor a type alias DataConstructorDetail = - DataConstructor { info : Info, source : TypeSource } + DataConstructor { info : Info, source : TypeSource, signature : TermSignature } type alias DataConstructorSummary = diff --git a/src/Code/DefinitionDetailTooltip.elm b/src/Code/DefinitionDetailTooltip.elm new file mode 100644 index 00000000..45fead45 --- /dev/null +++ b/src/Code/DefinitionDetailTooltip.elm @@ -0,0 +1,371 @@ +module Code.DefinitionDetailTooltip exposing (Model, Msg, init, tooltipConfig, update) + +import Code.CodebaseApi as CodebaseApi +import Code.Config exposing (Config) +import Code.Definition.AbilityConstructor exposing (AbilityConstructor(..), AbilityConstructorDetail) +import Code.Definition.DataConstructor as DataConstructor exposing (DataConstructor(..), DataConstructorDetail) +import Code.Definition.Reference as Reference exposing (Reference(..)) +import Code.Definition.Source as Source +import Code.Definition.Term as Term exposing (Term(..), TermDetail, termSignatureSyntax) +import Code.Definition.Type as Type exposing (Type(..), TypeDetail, typeSourceSyntax) +import Code.FullyQualifiedName as FQN +import Code.Hash as Hash +import Code.Syntax as Syntax +import Code.Syntax.SyntaxSegment as SyntaxSegment +import Dict exposing (Dict) +import Html exposing (div, span, text) +import Html.Attributes exposing (class) +import Json.Decode as Decode exposing (at, field) +import Lib.HttpApi as HttpApi exposing (ApiRequest, HttpResult) +import Lib.Util as Util +import RemoteData exposing (RemoteData(..), WebData) +import UI.Placeholder as Placeholder +import UI.Tooltip as Tooltip exposing (Tooltip) + + + +-- MODEL + + +type DefinitionDetail + = TermHover (TermDetail {}) + | TypeHover (TypeDetail {}) + | DataConstructorHover DataConstructorDetail + | AbilityConstructorHover AbilityConstructorDetail + + +type alias Model = + { activeTooltip : Maybe ( Reference, WebData DefinitionDetail ) + , summaries : Dict String ( Reference, WebData DefinitionDetail ) + } + + +init : Model +init = + { activeTooltip = Nothing + , summaries = Dict.empty + } + + + +-- UPDATE + + +type Msg + = ShowTooltip Reference + | FetchDefinition Reference + | HideTooltip Reference + | FetchDefinitionFinished Reference (HttpResult DefinitionDetail) + + +update : Config -> Msg -> Model -> ( Model, Cmd Msg ) +update config msg model = + let + debounceDelay = + 300 + in + case msg of + ShowTooltip ref -> + let + cached = + Dict.get (Reference.toString ref) model.summaries + in + case cached of + Nothing -> + ( model, Util.delayMsg debounceDelay (FetchDefinition ref) ) + + Just _ -> + ( { model | activeTooltip = cached }, Cmd.none ) + + FetchDefinition ref -> + let + fetchDef = + ( { model | activeTooltip = Just ( ref, Loading ) } + , fetchDefinition config ref |> HttpApi.perform config.api + ) + in + case model.activeTooltip of + Just ( r, Loading ) -> + if Reference.equals ref r then + ( model, Cmd.none ) + + else + -- If we've moved on to hovering over a different + -- definition while another was loading, discard the + -- original request + fetchDef + + Just _ -> + ( model, Cmd.none ) + + Nothing -> + fetchDef + + HideTooltip _ -> + ( { model | activeTooltip = Nothing }, Cmd.none ) + + FetchDefinitionFinished ref d -> + case model.activeTooltip of + Just ( r, _ ) -> + if Reference.equals ref r then + let + newActiveTooltip = + ( r, RemoteData.fromResult d ) + + updatedAlreadyFetched = + Dict.insert (Reference.toString ref) newActiveTooltip model.summaries + in + ( { model | activeTooltip = Just newActiveTooltip, summaries = updatedAlreadyFetched }, Cmd.none ) + + else + ( { model | activeTooltip = Nothing }, Cmd.none ) + + Nothing -> + ( { model | activeTooltip = Nothing }, Cmd.none ) + + + +-- HELPERS + + +{-| This is intended to be used over `view`, and comes with a way to map the msg. +-} +tooltipConfig : (Msg -> msg) -> Model -> Syntax.TooltipConfig msg +tooltipConfig toMsg model = + { toHoverStart = ShowTooltip >> toMsg + , toHoverEnd = HideTooltip >> toMsg + , toTooltip = \ref -> view model ref + } + + + +-- EFFECTS + + +fetchDefinition : Config -> Reference -> ApiRequest DefinitionDetail Msg +fetchDefinition { toApiEndpoint, perspective } ref = + CodebaseApi.Definition + { perspective = perspective, ref = ref } + |> toApiEndpoint + |> HttpApi.toRequest (decodeDetail ref) + (FetchDefinitionFinished ref) + + + +-- VIEW + + +viewDetail : WebData DefinitionDetail -> Maybe (Tooltip.Content msg) +viewDetail detail = + let + isList h = + Hash.toString h == "##Sequence" + + isTuple h n = + Hash.toString h + == "#2lg4ah6ir6t129m33d7gssnigacral39qdamo20mn6r2vefliubpeqnjhejai9ekjckv0qnu9mlu3k9nbpfhl2schec4dohn7rjhjt8" + || (FQN.toString n == ")") + || (FQN.toString n == "(") + + viewBuiltinType h name = + let + name_ = + if isList h then + "List" + + else + FQN.toString name + in + span + [] + [ span [ class "data-type-modifier" ] [ text "builtin " ] + , span [ class "data-type-keyword" ] [ text "type" ] + , span [ class "type-reference" ] [ text (" " ++ name_) ] + ] + + viewTypeSourceSyntax h fqn source = + if isTuple h fqn then + [ SyntaxSegment.SyntaxSegment SyntaxSegment.DataTypeModifier "structural" + , SyntaxSegment.SyntaxSegment SyntaxSegment.Blank " " + , SyntaxSegment.SyntaxSegment SyntaxSegment.DataTypeKeyword "type" + , SyntaxSegment.SyntaxSegment SyntaxSegment.Blank " " + , SyntaxSegment.SyntaxSegment (SyntaxSegment.HashQualifier "Tuple") "Tuple" + , SyntaxSegment.SyntaxSegment SyntaxSegment.Blank " " + , SyntaxSegment.SyntaxSegment SyntaxSegment.DataTypeParams "a" + , SyntaxSegment.SyntaxSegment SyntaxSegment.Blank " " + , SyntaxSegment.SyntaxSegment SyntaxSegment.DataTypeParams "b" + ] + |> Syntax.fromList + |> Maybe.map (Type.Source >> typeSourceSyntax) + |> Maybe.withDefault (typeSourceSyntax source) + + else + typeSourceSyntax source + + viewDetail_ s = + case s of + TermHover (Term _ _ { source }) -> + Source.viewTermSource Syntax.NotLinked source + + TypeHover (Type h _ { info, source }) -> + source + |> viewTypeSourceSyntax source + |> Maybe.map (Syntax.view Syntax.NotLinked) + |> Maybe.withDefault (viewBuiltinType h info.name) + + AbilityConstructorHover (AbilityConstructor _ { signature }) -> + Syntax.view Syntax.NotLinked (termSignatureSyntax signature) + + DataConstructorHover (DataConstructor _ { signature }) -> + Syntax.view Syntax.NotLinked (termSignatureSyntax signature) + + loading = + Tooltip.rich + (Placeholder.text + |> Placeholder.withSize Placeholder.Small + |> Placeholder.withLength Placeholder.Small + |> Placeholder.withIntensity Placeholder.Subdued + |> Placeholder.view + ) + in + case detail of + NotAsked -> + Just loading + + Loading -> + Just loading + + Success sum -> + Just (Tooltip.rich (div [ class "monochrome" ] [ viewDetail_ sum ])) + + Failure _ -> + Nothing + + +view : Model -> Reference -> Maybe (Tooltip msg) +view model reference = + let + withMatchingReference ( r, d ) = + if Reference.equals r reference then + Just d + + else + Nothing + + view_ d = + d + |> viewDetail + |> Maybe.map Tooltip.tooltip + |> Maybe.map (Tooltip.withArrow Tooltip.Start) + |> Maybe.map (Tooltip.withPosition Tooltip.Below) + |> Maybe.map Tooltip.show + in + model.activeTooltip + |> Maybe.andThen withMatchingReference + |> Maybe.andThen view_ + + + +-- JSON DECODERS + + +decodeTypeDetail : Decode.Decoder DefinitionDetail +decodeTypeDetail = + let + makeDetail fqn name_ source = + { fqn = fqn + , name = name_ + , namespace = FQN.namespaceOf name_ fqn + , source = source + } + in + Decode.map TypeHover + (Decode.map3 Type + (field "hash" Hash.decode) + (Type.decodeTypeCategory [ "tag" ]) + (Decode.map3 makeDetail + (field "displayName" FQN.decode) + (field "displayName" FQN.decode) + (Type.decodeTypeSource [ "detail", "tag" ] [ "detail", "contents" ]) + ) + ) + + +decodeTermDetail : Decode.Decoder DefinitionDetail +decodeTermDetail = + let + makeDetail fqn name_ signature = + { fqn = fqn + , name = name_ + , namespace = FQN.namespaceOf name_ fqn + , signature = signature + } + in + Decode.map TermHover + (Decode.map3 Term + (field "hash" Hash.decode) + (Term.decodeTermCategory [ "tag" ]) + (Decode.map3 makeDetail + (field "displayName" FQN.decode) + (field "displayName" FQN.decode) + (Term.decodeSignature [ "detail", "contents" ]) + ) + ) + + +decodeAbilityConstructorDetail : Decode.Decoder DefinitionDetail +decodeAbilityConstructorDetail = + let + makeDetail fqn name_ signature = + { fqn = fqn + , name = name_ + , namespace = FQN.namespaceOf name_ fqn + , signature = signature + } + in + Decode.map AbilityConstructorHover + (Decode.map2 AbilityConstructor + (field "hash" Hash.decode) + (Decode.map3 makeDetail + (field "displayName" FQN.decode) + (field "displayName" FQN.decode) + (DataConstructor.decodeSignature [ "detail", "contents" ]) + ) + ) + + +decodeDataConstructorDetail : Decode.Decoder DefinitionDetail +decodeDataConstructorDetail = + let + makeDetail fqn name_ signature = + { fqn = fqn + , name = name_ + , namespace = FQN.namespaceOf name_ fqn + , signature = signature + } + in + Decode.map DataConstructorHover + (Decode.map2 DataConstructor + (at [ "hash" ] Hash.decode) + (Decode.map3 makeDetail + (field "displayName" FQN.decode) + (field "displayName" FQN.decode) + (DataConstructor.decodeSignature [ "detail", "contents" ]) + ) + ) + + +decodeDetail : Reference -> Decode.Decoder DefinitionDetail +decodeDetail ref = + case ref of + TermReference _ -> + decodeTermDetail + + TypeReference _ -> + decodeTypeDetail + + AbilityConstructorReference _ -> + decodeAbilityConstructorDetail + + DataConstructorReference _ -> + decodeDataConstructorDetail diff --git a/src/css/code/workspace-item.css b/src/css/code/workspace-item.css index bdaf64da..b2a6a446 100644 --- a/src/css/code/workspace-item.css +++ b/src/css/code/workspace-item.css @@ -91,6 +91,7 @@ display: flex; flex-direction: row; align-items: center; + gap: 0.25rem; } .workspace-item .workspace-item_header .workspace-item_info-items { @@ -98,7 +99,7 @@ flex-direction: row; align-items: center; gap: 1rem; - margin-left: 1rem; + margin-left: 0.5rem; } .workspace-item .workspace-item_header .workspace-item_info-item {