refactor

HugoPeters1024 · Aug 29, 2022 · 25513e7 · 25513e7
1 parent 48594fc
commit 25513e7
Show file tree

Hide file tree

Showing 6 changed files with 100 additions and 63 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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