Improve workspace item gap

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 =

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 =

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