extra/gemini/ui/ui.factor

   1 ! Copyright (C) 2021 John Benediktsson
   2 ! See https://factorcode.org/license.txt for BSD license
   3
   4 USING: accessors arrays debugger fonts gemini kernel
   5 math.vectors models present sequences splitting ui ui.commands
   6 ui.gadgets ui.gadgets.editors ui.gadgets.panes
   7 ui.gadgets.scrollers ui.gadgets.status-bar ui.gadgets.toolbar
   8 ui.gadgets.tracks ui.gadgets.viewports ui.gestures ui.operations
   9 ui.tools.browser ui.tools.browser.history ui.tools.common urls
  10 webbrowser ;
  11
  12 IN: gemini.ui
  13
  14 TUPLE: gemini-gadget < tool history scroller url-field ;
  15
  16 gemini-gadget default-font-size { 50 50 } n*v set-tool-dim
  17
  18 M: gemini-gadget history-value
  19     [ control-value ] [ scroller>> scroll-position ]
  20     bi 2array ;
  21
  22 M: gemini-gadget set-history-value
  23     [ first2 ] dip
  24     [ set-control-value ] [ scroller>> set-scroll-position ]
  25     bi-curry bi* ;
  26
  27 M: gemini-gadget model-changed
  28     [ value>> present ]
  29     [ url-field>> editor>> set-editor-string ] bi* ;
  30
  31 : ?gemini-url ( obj -- url )
  32     present dup "://" subseq-of? [ "gemini://" prepend ] unless >url ;
  33
  34 : show-gemini ( url gemini-gadget -- )
  35     [ [ ?gemini-url ] [ f ] if* ] dip
  36     over [ protocol>> "gemini" = ] [ t ] if* [
  37         [
  38             2dup control-value =
  39             [ 2drop ] [ nip history>> add-history ] if
  40         ]
  41         [ set-control-value ]
  42         2bi
  43     ] [ drop open-url ] if ;
  44
  45 : <url-field> ( gemini-gadget -- field )
  46     '[ _ show-gemini ] <action-field>
  47         "Gemini URL" >>default-text
  48         white-interior ;
  49
  50 : <gemini-pane> ( gemini-gadget -- gadget )
  51     model>> [ '[ _ [ gemini. ] when* ] try ] <pane-control> ;
  52
  53 : <gemini-toolbar> ( browser -- toolbar )
  54     horizontal <track>
  55         0 >>fill
  56         1/2 >>align
  57         { 5 5 } >>gap
  58         over <toolbar> f track-add
  59         swap url-field>> 1 track-add ;
  60
  61 : add-gemini-toolbar ( track -- track )
  62     dup <gemini-toolbar> format-toolbar f track-add ;
  63
  64 : add-gemini-pane ( track -- track )
  65     dup dup <gemini-pane> margins
  66     <scroller> >>scroller scroller>> white-interior 1 track-add ;
  67
  68 : <gemini-gadget> ( -- gadget )
  69     vertical gemini-gadget new-track with-lines
  70         f <model> >>model
  71         dup <history> >>history
  72         dup <url-field> >>url-field
  73         add-gemini-toolbar
  74         add-gemini-pane ;
  75
  76 : open-gemini-window ( url -- )
  77     <gemini-gadget>
  78     [ "gemini" open-status-window ]
  79     [ show-gemini ] bi ;
  80
  81 : com-clear ( gemini -- )
  82     f swap set-control-value ;
  83
  84 : com-up ( gemini -- )
  85     [
  86         control-value dup [
  87             f >>query f >>anchor
  88             [ dup "/" tail? "./../" "./" ? url-append-path ] change-path
  89         ] when
  90     ]
  91     [ show-gemini ] bi ;
  92
  93 : com-gemini ( url -- )
  94     [ gemini-gadget? ] find-window
  95     [ [ raise-window ] [ gadget-child show-gemini ] bi ]
  96     [ open-gemini-window ] if* ;
  97
  98 gemini-gadget "toolbar" f {
  99     { f com-back }
 100     { f com-forward }
 101     { f com-up }
 102     { f com-clear }
 103 } define-command-map
 104
 105 gemini-gadget "scrolling" f {
 106     { T{ key-down f f "UP" } com-scroll-up }
 107     { T{ key-down f f "DOWN" } com-scroll-down }
 108     { T{ key-down f f "PAGE_UP" } com-page-up }
 109     { T{ key-down f f "PAGE_DOWN" } com-page-down }
 110 } define-command-map
 111
 112 [ dup url? [ protocol>> "gemini" = ] [ drop f ] if ] \ com-gemini H{ { +primary+ t } } define-operation
 113
 114 : gemini-main ( -- )
 115     [ "gemini.circumlunar.space" open-gemini-window ] with-ui ;
 116
 117 MAIN: gemini-main