From 25513e7c2ab168df11daea42b2b5a96e9960c18f Mon Sep 17 00:00:00 2001 From: HugoPeters1024 Date: Mon, 29 Aug 2022 12:58:06 +0200 Subject: [PATCH] refactor --- frontend/src/ElmHelpers.elm | 4 +++ frontend/src/Main.elm | 21 ++++++++++-- frontend/src/Pages/Code.elm | 67 +++++++++++++++---------------------- frontend/src/Ppr.elm | 51 +++++++++++++++++++--------- frontend/src/PprRender.elm | 12 +++++-- frontend/src/Types.elm | 8 ++--- 6 files changed, 100 insertions(+), 63 deletions(-) diff --git a/frontend/src/ElmHelpers.elm b/frontend/src/ElmHelpers.elm index 0a88129..ee3ec15 100644 --- a/frontend/src/ElmHelpers.elm +++ b/frontend/src/ElmHelpers.elm @@ -59,6 +59,10 @@ indexList : Int -> List a -> Maybe a indexList n xs = List.head (List.drop n xs) +addIf : Bool -> a -> List a -> List a +addIf b a xs = if b then a::xs else xs + + removeDuplicatesKey : (a -> comparable) -> List a -> List a removeDuplicatesKey f = Set.Any.toList << Set.Any.fromList f diff --git a/frontend/src/Main.elm b/frontend/src/Main.elm index e5d3432..614b650 100644 --- a/frontend/src/Main.elm +++ b/frontend/src/Main.elm @@ -81,7 +81,7 @@ getCtxMenuItems context = case context of let always = [(ContextMenu.item "Rename", Code.mkCodeMsg tabid (CodeMsgRenameModalOpen var))] onBinder = let wBinder bndr = case bndr of - Binder b -> [(ContextMenu.item "Jump to First Occurrance", Code.mkCodeMsg tabid (CodeMsgSetPhase slot b.binderCreatedPhaseId))] + Binder b -> [(ContextMenu.item ("GOTO First Occ. (Pass " ++ String.fromInt b.binderCreatedPhaseId ++ ")"), Code.mkCodeMsg tabid (CodeMsgSetPhase slot b.binderCreatedPhaseId))] _ -> [] in case var of VarBinder bndr -> wBinder bndr @@ -93,6 +93,23 @@ getCtxMenuItems context = case context of in [always ++ onBinder ++ onToplevel] +ctxConfig : ContextMenu.Config +ctxConfig = + let d = ContextMenu.defaultConfig + lightGray = "rgb(238, 238, 238)" + deepBlue = "rgb(62,126,255)" + in + { d + | direction = ContextMenu.RightBottom + , overflowX = ContextMenu.Mirror + , overflowY = ContextMenu.Shift + , containerColor = lightGray + , hoverColor = deepBlue + , invertText = True + , cursor = ContextMenu.Arrow + , rounded = True + } + view : Model -> Document Msg view m = { title = "hs-comprehension" @@ -102,7 +119,7 @@ view m = , node "link" [rel "stylesheet", href "/pygments.css", type_ "text/css"] [] , div [] [ContextMenu.view - ContextMenu.defaultConfig + ctxConfig MsgCtxMenu getCtxMenuItems m.ctxMenu diff --git a/frontend/src/Pages/Code.elm b/frontend/src/Pages/Code.elm index eeff2e0..c17f10b 100644 --- a/frontend/src/Pages/Code.elm +++ b/frontend/src/Pages/Code.elm @@ -93,8 +93,8 @@ makeCodeTab model captures = , moduleDropdown = Dropdown.initialState , hideTypes = False , hideModules = False - , disambiguateVariables = False - , showRecursiveGroups = False + , hideDisambiguation = True + , hideRecursiveGroups = True , selectedTopLevels = [] , renameModal = { visiblity = Modal.hidden @@ -134,8 +134,8 @@ update msg tab = case msg of CodeMsgSelectVar var -> ({tab | selectedVar = Just var}, Cmd.none) CodeMsgToggleHideTypes -> ({tab | hideTypes = not tab.hideTypes}, Cmd.none) CodeMsgToggleHideModules -> ({tab | hideModules = not tab.hideModules}, Cmd.none) - CodeMsgToggleDisambiguateVariables -> ({tab | disambiguateVariables = not tab.disambiguateVariables}, Cmd.none) - CodeMsgToggleShowRecursiveGroups -> ({tab | showRecursiveGroups = not tab.showRecursiveGroups}, Cmd.none) + CodeMsgToggleHideDisambiguation -> ({tab | hideDisambiguation = not tab.hideDisambiguation}, Cmd.none) + CodeMsgToggleHideRecursiveGroups -> ({tab | hideRecursiveGroups = not tab.hideRecursiveGroups}, Cmd.none) CodeMsgModuleDropdown state -> ({tab | moduleDropdown = state}, Cmd.none) CodeMsgSlider slot slidermsg -> let updateCaptureTab : CodeTabCapture -> CodeTabCapture @@ -241,35 +241,6 @@ viewRenameModal tab = |> Modal.view tab.renameModal.visiblity -renderVarName : CodeTab -> Var -> String -renderVarName tab var = - let postfix : String -> String - postfix i = if tab.disambiguateVariables then i ++ "_" ++ HsCore.Helpers.varGHCUnique var else i - - renamed : String -> String - renamed i = case Dict.get (varToInt var) tab.varRenames of - Just o -> o - Nothing -> i - - disabled : String -> String - disabled i = case var of - VarBinder bndr -> - if HsCore.Helpers.binderIsUnused bndr then "_" else i - _ -> i - - prefix : String -> String - prefix i = case var of - VarExternal (ExternalName e) -> - if tab.hideModules then i else e.externalModuleName ++ "." ++ i - _ -> i - - in - varName var - |> renamed - |> postfix - |> disabled - |> prefix - hideToplevels : Set Int -> Phase -> Phase hideToplevels hidden phase = let q : TopBindingInfo -> Bool @@ -286,7 +257,9 @@ viewCode : Model -> CodeTab -> CodeTabCapture -> Html Msg viewCode model tab modtab = let pprEnv : Ppr.Env pprEnv = - { renderVarName = renderVarName tab + { hideModules = tab.hideModules + , hideDisambiguation = tab.hideDisambiguation + , varRenames = tab.varRenames } pprRenderEnv : Ppr.PprRenderEnv @@ -315,7 +288,7 @@ viewCode model tab modtab = [ processDiff tab phase |> hideToplevels modtab.toplevelHides |> (if tab.hideTypes then eraseTypesPhase else identity) - |> (if tab.showRecursiveGroups then identity else \p -> {p | phaseTopBindings = removeRecursiveGroups p.phaseTopBindings}) + |> (if tab.hideRecursiveGroups then \p -> {p | phaseTopBindings = removeRecursiveGroups p.phaseTopBindings} else identity) |> Ppr.pprPhase pprEnv mod.moduleName |> Ppr.renderHtml pprRenderEnv ] @@ -355,8 +328,8 @@ viewInfo model tab = HtmlHelpers.list [ checkbox tab.hideTypes CodeMsgToggleHideTypes "Hide Types" , checkbox tab.hideModules CodeMsgToggleHideModules "Hide Module Qualifiers" - , checkbox tab.disambiguateVariables CodeMsgToggleDisambiguateVariables "Disambiguate Variables Names" - , checkbox tab.showRecursiveGroups CodeMsgToggleShowRecursiveGroups "Show Recursive Groups" + , checkbox tab.hideDisambiguation CodeMsgToggleHideDisambiguation "Hide Uniques" + , checkbox tab.hideRecursiveGroups CodeMsgToggleHideRecursiveGroups "Hide Recursive Grouping" , hr [] [] , h4 [] [text "Selected Variable"] , fromMaybe (h5 [] [text "No term selected"]) (Maybe.map (viewVarInfo tab) tab.selectedVar) @@ -367,10 +340,24 @@ viewInfo model tab = |> Card.view viewHideOptions : Model -> CodeTab -> Html CodeTabMsg -viewHideOptions model tab = div [] +viewHideOptions model tab = HtmlHelpers.list [ h4 [] [text "Hide Options"] - , button [onClick CodeMsgHideToplevelDiffTemplate] [text "Only show diff"] - , button [onClick CodeMsgUnhideAll] [text "Unhide all"] + , Button.button + [ Button.info + , Button.disabled (Dict.size tab.captureSlots < 2) + , Button.attrs + [ onClick CodeMsgHideToplevelDiffTemplate + , title (if (Dict.size tab.captureSlots < 2) then "At least 2 open captures required" else "Hide toplevel definitions that do not differ") + ] + ] + [text "Hide Unchanged"] + , Button.button + [ Button.info + , Button.attrs + [ onClick CodeMsgUnhideAll + ] + ] + [text "Unhide all"] ] viewVarInfo : CodeTab -> Var -> Html CodeTabMsg diff --git a/frontend/src/Ppr.elm b/frontend/src/Ppr.elm index b37a7ef..825c4b3 100644 --- a/frontend/src/Ppr.elm +++ b/frontend/src/Ppr.elm @@ -6,7 +6,7 @@ import HsCore.Helpers exposing (..) import Pretty exposing (..) import Pretty.Renderer exposing (..) -import ElmHelpers +import Dict exposing (Dict) type Tag = TagVar Var @@ -20,9 +20,40 @@ type Tag type alias PP = Doc Tag type alias Env = - { renderVarName : Var -> String + { hideModules : Bool + , hideDisambiguation : Bool + , varRenames : Dict Int String } +renderVarName : Env -> Var -> String +renderVarName env var = + let postfix : String -> String + postfix i = if env.hideDisambiguation then i else i ++ "_" ++ HsCore.Helpers.varGHCUnique var + + renamed : String -> String + renamed i = case Dict.get (varToInt var) env.varRenames of + Just o -> o + Nothing -> i + + disabled : String -> String + disabled i = case var of + VarBinder bndr -> + if HsCore.Helpers.binderIsUnused bndr then "_" else i + _ -> i + + prefix : String -> String + prefix i = case var of + VarExternal (ExternalName e) -> + if env.hideModules then i else e.externalModuleName ++ "." ++ i + _ -> i + + in + varName var + |> renamed + |> postfix + |> disabled + |> prefix + keyword : String -> PP keyword t = taggedString t TagKeyword @@ -61,7 +92,8 @@ pprTopBinding : Env -> TopBinding -> PP pprTopBinding env topb = case topb of NonRecTopBinding tinfo -> pprTopBindingInfo env tinfo RecTopBinding tinfos -> - string "Rec {" + taggedString ("Rec(" ++ String.fromInt (List.length tinfos) ++ ")") TagOperator + |> a (string " {") |> a line |> a (indent 2 (join doubleline (List.map (pprTopBindingInfo env) tinfos))) |> a line @@ -191,18 +223,7 @@ pprBinderThunk env thunk = case thunk of pprVar : Env -> Var -> PP -pprVar env var = - let cname = env.renderVarName var - in case var of - VarExternal (ExternalName e) -> - case ElmHelpers.popLast (String.split "." cname) of - Just ([], _) -> Pretty.taggedString cname (TagVar var) - Just (qual, varname) -> combine - [ Pretty.taggedString (String.join "." qual ++ ".") TagModule - , Pretty.taggedString varname (TagVar var) - ] - _ -> Pretty.taggedString cname (TagVar var) - _ -> Pretty.taggedString cname (TagVar var) +pprVar env var = Pretty.taggedString (renderVarName env var) (TagVar var) pprType : Env -> Type -> PP diff --git a/frontend/src/PprRender.elm b/frontend/src/PprRender.elm index 4d3005d..95a5860 100644 --- a/frontend/src/PprRender.elm +++ b/frontend/src/PprRender.elm @@ -4,6 +4,7 @@ import Types exposing (..) import HsCore.Helpers exposing (..) import Dict exposing (Dict) +import ElmHelpers as EH import Ppr exposing (..) import Html exposing (..) @@ -14,6 +15,7 @@ import Pretty import Pretty.Renderer import ContextMenu +import Generated.Types exposing (..) type alias PprRenderEnv = { codeTabId : TabId @@ -38,11 +40,17 @@ renderVar : PprRenderEnv -> String -> Var -> Html Msg renderVar env content var = let className = if varIsConstructor var then "k" else "" ctxMenu = ContextMenu.open MsgCtxMenu (CtxCodeVar env.codeTabId env.codeTabSlotId var) + (prefix, base_name) = case EH.popLast (String.split "." content) of + Just ([], n) -> ("", n) + Just (qual, n) -> ((String.join "." qual) ++ ".", n) + _ -> ("", "") varName = case Dict.get (varToInt var) env.renameDict of Just x -> x - Nothing -> content + Nothing -> base_name in a [class "no-style", onClick (MsgCodeMsg env.codeTabId (CodeMsgSelectVar var))] - [span [ctxMenu, class className, class (varHighlightClass env var), title (typeToString (varType var))] [text varName]] + [span + [ctxMenu, class className, class (varHighlightClass env var), title (typeToString (varType var))] + [span [class "nc"] [text prefix], text varName]] htmlTagged : PprRenderEnv -> Tag -> String -> List (Html Msg) -> List (Html Msg) htmlTagged env tag content next = diff --git a/frontend/src/Types.elm b/frontend/src/Types.elm index b1b0ecc..4c8c71d 100644 --- a/frontend/src/Types.elm +++ b/frontend/src/Types.elm @@ -68,8 +68,8 @@ type alias CodeTab = , selectedVar : Maybe Var , hideTypes : Bool , hideModules : Bool - , disambiguateVariables : Bool - , showRecursiveGroups : Bool + , hideDisambiguation : Bool + , hideRecursiveGroups : Bool , selectedTopLevels : List TopBindingInfo , renameModal : CodeTabRenameModal , varRenames : Dict Int String @@ -82,8 +82,8 @@ type CodeTabMsg | CodeMsgSelectVar Var | CodeMsgToggleHideTypes | CodeMsgToggleHideModules - | CodeMsgToggleDisambiguateVariables - | CodeMsgToggleShowRecursiveGroups + | CodeMsgToggleHideDisambiguation + | CodeMsgToggleHideRecursiveGroups | CodeMsgModuleDropdown Dropdown.State | CodeMsgSlider SlotId Slider.Msg | CodeMsgMarkTopLevel TopBindingInfo