git.iko.soy/elk
on master help sign in
Add starting implementation of dependency picking UI for reactor
6dc8960Evan Czaplicki
reactor/src/Deps.elmnew file+1210
compare with master
unifiedsplit
@@ -0,0 +1,1210 @@
1+module Deps exposing (main)
2+
3+
4+import Browser
5+import Browser.Dom as Dom
6+import Dict exposing (Dict)
7+import Elm.Constraint as Constraint exposing (Constraint)
8+import Html exposing (..)
9+import Html.Attributes exposing (..)
10+import Html.Events exposing (..)
11+import Html.Keyed as Keyed
12+import Html.Lazy exposing (..)
13+import Http
14+import Json.Decode as D
15+import Json.Encode as E
16+import Svg
17+import Svg.Attributes as S
18+import Task
19+
20+
21+
22+-- MAIN
23+
24+
25+main =
26+ Browser.document
27+ { init = init
28+ , view = view
29+ , update = update
30+ , subscriptions = \_ -> Sub.none
31+ }
32+
33+
34+
35+-- MODEL
36+
37+
38+type alias Model =
39+ { status : Status
40+ , id : Int
41+ -- queries
42+ , search : Search
43+ , registry : Registry
44+ -- history
45+ , past : List Change
46+ , future : List Change
47+ , origin : Origin
48+ }
49+
50+
51+
52+-- STATUS
53+
54+
55+type Status
56+ = Failure Checkpoint (List Change)
57+ | Waiting Checkpoint (List Change)
58+ | Success Checkpoint
59+
60+
61+type alias Checkpoint =
62+ { direct : Dict String Bounds
63+ , indirect : Dict String Bounds
64+ }
65+
66+
67+type Bounds
68+ = New Version NewBounds
69+ | Old Version Version OldBounds
70+
71+
72+type NewBounds
73+ = NAny
74+ | NCustom Constraint
75+
76+
77+type OldBounds
78+ = OLocked
79+ | OPatch
80+ | OMinor
81+ | OMajor
82+ | OAny
83+ | OCustom Constraint
84+
85+
86+
87+-- CHANGES
88+
89+
90+type Change
91+ = MassLock
92+ | MassPatch
93+ | MassMinor
94+ | MassMajor
95+ | AddDirect String
96+ | TweakOldDirect String OldBounds
97+ | TweakNewDirect String NewBounds
98+ | TweakOldIndirect String OldBounds
99+ | TweakNewIndirect String NewBounds
100+ | DeleteDirect String
101+ | DeleteIndirect String
102+
103+
104+
105+-- PREVIEW
106+
107+
108+type alias Preview =
109+ { direct : Dict String PBounds
110+ , indirect : Dict String PBounds
111+ }
112+
113+
114+type PBounds
115+ = PNew (Maybe Version) NewBounds
116+ | POld Version Version OldBounds
117+
118+
119+toPreview : Origin -> Checkpoint -> List Change -> Preview
120+toPreview origin checkpoint changes =
121+ let
122+ toPreviewBounds _ bounds =
123+ case bounds of
124+ New vsn nb -> PNew (Just vsn) nb
125+ Old old new ob -> POld old new ob
126+
127+ start =
128+ { direct = Dict.map toPreviewBounds checkpoint.direct
129+ , indirect = Dict.map toPreviewBounds checkpoint.indirect
130+ }
131+ in
132+ List.foldr (step origin) start changes
133+
134+
135+step : Origin -> Change -> Preview -> Preview
136+step origin change preview =
137+ case change of
138+ MassLock ->
139+ massChange OLocked preview
140+
141+ MassPatch ->
142+ massChange OPatch preview
143+
144+ MassMinor ->
145+ massChange OMinor preview
146+
147+ MassMajor ->
148+ massChange OMajor preview
149+
150+ AddDirect pkg ->
151+ let
152+ pBound =
153+ case Dict.get pkg origin.direct of
154+ Just vsn -> POld vsn vsn OLocked
155+ Nothing ->
156+ case Dict.get pkg origin.indirect of
157+ Just vsn -> POld vsn vsn OLocked
158+ Nothing -> PNew Nothing NAny
159+ in
160+ { direct = Dict.insert pkg pBound preview.direct
161+ , indirect = Dict.remove pkg preview.indirect
162+ }
163+
164+ TweakOldDirect pkg oldBounds ->
165+ { direct = Dict.update pkg (alterOld oldBounds) preview.direct
166+ , indirect = preview.indirect
167+ }
168+
169+ TweakNewDirect pkg newBounds ->
170+ { direct = Dict.update pkg (alterNew newBounds) preview.direct
171+ , indirect = preview.indirect
172+ }
173+
174+ TweakOldIndirect pkg oldBounds ->
175+ { direct = preview.direct
176+ , indirect = Dict.update pkg (alterOld oldBounds) preview.indirect
177+ }
178+
179+ TweakNewIndirect pkg newBounds ->
180+ { direct = preview.direct
181+ , indirect = Dict.update pkg (alterNew newBounds) preview.indirect
182+ }
183+
184+ DeleteDirect pkg ->
185+ { direct = Dict.remove pkg preview.direct
186+ , indirect = preview.indirect
187+ }
188+
189+ DeleteIndirect pkg ->
190+ { direct = preview.direct
191+ , indirect = Dict.remove pkg preview.indirect
192+ }
193+
194+
195+massChange : OldBounds -> Preview -> Preview
196+massChange oldBounds preview =
197+ let
198+ changeBounds _ bounds =
199+ case bounds of
200+ PNew vsn newBounds -> PNew vsn newBounds
201+ POld old new _ -> POld old new oldBounds
202+ in
203+ { direct = Dict.map changeBounds preview.direct
204+ , indirect = Dict.map changeBounds preview.indirect
205+ }
206+
207+
208+alterOld : OldBounds -> Maybe PBounds -> Maybe PBounds
209+alterOld ob maybeBounds =
210+ case maybeBounds of
211+ Nothing ->
212+ Nothing
213+
214+ Just bounds ->
215+ case bounds of
216+ PNew vsn nb -> Just (PNew vsn nb)
217+ POld old new _ -> Just (POld old new ob)
218+
219+
220+alterNew : NewBounds -> Maybe PBounds -> Maybe PBounds
221+alterNew nb maybeBounds =
222+ case maybeBounds of
223+ Nothing ->
224+ Nothing
225+
226+ Just bounds ->
227+ case bounds of
228+ PNew vsn _ -> Just (PNew vsn nb)
229+ POld old new ob -> Just (POld old new ob)
230+
231+
232+
233+-- INIT
234+
235+
236+init : () -> (Model, Cmd Msg)
237+init () =
238+ let
239+ origin = startTODO
240+ chkp = toInitialCheckpoint origin
241+ in
242+ await chkp []
243+ { status = Waiting chkp []
244+ , id = 0
245+ , search = { query = "", focus = Nothing }
246+ , registry = registryTODO
247+ , past = []
248+ , future = []
249+ , origin = origin
250+ }
251+
252+
253+type alias Origin =
254+ { direct : Dict String Version
255+ , indirect : Dict String Version
256+ }
257+
258+
259+startTODO : Origin
260+startTODO =
261+ { direct =
262+ Dict.fromList
263+ [ ("elm/browser", Version 1 0 1)
264+ , ("elm/core", Version 1 0 2)
265+ , ("elm/html", Version 1 0 0)
266+ , ("elm/http", Version 2 0 0)
267+ , ("elm/json", Version 1 1 2)
268+ , ("elm/project-metadata-utils", Version 1 0 0)
269+ , ("elm/svg", Version 1 0 1)
270+ , ("elm-explorations/markdown", Version 1 0 0)
271+ ]
272+ , indirect =
273+ Dict.fromList
274+ [ ("elm/parser", Version 1 1 0)
275+ , ("elm/time", Version 1 0 0)
276+ , ("elm/url", Version 1 0 0)
277+ , ("elm/virtual-dom", Version 1 0 2)
278+ ]
279+ }
280+
281+
282+
283+-- CHECKPOINTS
284+
285+
286+toInitialCheckpoint : Origin -> Checkpoint
287+toInitialCheckpoint origin =
288+ { direct = Dict.map (\_ v -> Old v v OLocked) origin.direct
289+ , indirect = Dict.map (\_ v -> Old v v OLocked) origin.indirect
290+ }
291+
292+
293+toCheckpoint : Dict String Version -> Preview -> Maybe Checkpoint
294+toCheckpoint solution preview =
295+ let
296+ direct = Dict.foldr (addBound solution) Dict.empty preview.direct
297+ indirect = Dict.foldr (addBound solution) Dict.empty preview.indirect
298+ in
299+ if Dict.size direct == Dict.size preview.direct then
300+ Just (Checkpoint direct indirect)
301+ else
302+ Nothing
303+
304+
305+addBound : Dict String Version -> String -> PBounds -> Dict String Bounds -> Dict String Bounds
306+addBound solution pkg bounds dict =
307+ case Dict.get pkg solution of
308+ Nothing ->
309+ dict
310+
311+ Just new ->
312+ case bounds of
313+ PNew _ newBounds ->
314+ Dict.insert pkg (New new newBounds) dict
315+
316+ POld old _ oldBounds ->
317+ Dict.insert pkg (Old old new oldBounds) dict
318+
319+
320+
321+-- UPDATE
322+
323+
324+type Msg
325+ = NoOp
326+ | Commit Change
327+ | Undo
328+ | Redo
329+ | GotSolution Int (Result Http.Error (Dict String Version))
330+ | SearchTouched SearchMsg
331+
332+
333+update : Msg -> Model -> (Model, Cmd Msg)
334+update msg model =
335+ case Debug.log "msg" msg of
336+ NoOp ->
337+ ( model, Cmd.none )
338+
339+ Commit latest ->
340+ let (checkpoint, changes) = getCheckpoint model.status in
341+ await checkpoint (latest::changes) { model | future = [] }
342+
343+ Undo ->
344+ case getCheckpoint model.status of
345+ (checkpoint, latest :: previous) ->
346+ await checkpoint previous { model | future = latest :: model.future }
347+
348+ (_, []) ->
349+ case model.past of
350+ [] -> ( model, Cmd.none )
351+
352+ latest :: previous ->
353+ await (toInitialCheckpoint model.origin) previous
354+ { model | past = [], future = latest :: model.future }
355+
356+ Redo ->
357+ case model.future of
358+ [] ->
359+ ( model, Cmd.none )
360+
361+ next :: nexterer ->
362+ let (checkpoint, changes) = getCheckpoint model.status in
363+ await checkpoint (next::changes) { model | future = nexterer }
364+
365+ GotSolution id result ->
366+ if model.id /= id then
367+ ( model, Cmd.none )
368+ else
369+ let
370+ (oldCheckpoint, changes) = getCheckpoint model.status
371+ in
372+ case result of
373+ Err _ ->
374+ ( { model | status = Failure oldCheckpoint changes }, Cmd.none )
375+
376+ Ok solution ->
377+ case toCheckpoint solution (toPreview model.origin oldCheckpoint changes) of
378+ Nothing ->
379+ ( { model | status = Failure oldCheckpoint changes }
380+ , Cmd.none
381+ )
382+
383+ Just newCheckpoint ->
384+ ( { model
385+ | status = Success newCheckpoint
386+ , past = changes ++ model.past
387+ }
388+ , Cmd.none
389+ )
390+
391+ SearchTouched searchMsg ->
392+ case updateSearch model.registry searchMsg model.search of
393+ SNone ->
394+ ( model, Cmd.none )
395+
396+ SUpdate newSearch ->
397+ ( { model | search = newSearch }
398+ , Cmd.none
399+ )
400+
401+ SManualBlur newSearch ->
402+ ( { model | search = newSearch }
403+ , Task.attempt (\_ -> NoOp) (Dom.blur searchDepsID)
404+ )
405+
406+ SAdd name ->
407+ let (checkpoint, changes) = getCheckpoint model.status in
408+ await checkpoint (AddDirect name :: changes)
409+ { model
410+ | search = { query = "", focus = Nothing }
411+ , future = []
412+ }
413+
414+
415+getCheckpoint : Status -> (Checkpoint, List Change)
416+getCheckpoint status =
417+ case status of
418+ Failure chkp cs -> (chkp, cs)
419+ Waiting chkp cs -> (chkp, cs)
420+ Success chkp -> (chkp, [])
421+
422+
423+await : Checkpoint -> List Change -> Model -> (Model, Cmd Msg)
424+await checkpoint changes model =
425+ let
426+ id = model.id + 1
427+ preview = toPreview model.origin checkpoint changes
428+ in
429+ (
430+ { model
431+ | status = Waiting checkpoint changes
432+ , id = id
433+ }
434+ ,
435+ Http.post
436+ { url = "/elm-stuff/solve"
437+ , body =
438+ Http.jsonBody <|
439+ E.object
440+ [ ("direct", E.dict identity encodeConstraint preview.direct)
441+ , ("indirect", E.dict identity encodeConstraint preview.indirect)
442+ ]
443+ , expect = Http.expectJson (GotSolution id) solutionDecoder
444+ }
445+ )
446+
447+
448+
449+-- VIEW
450+
451+
452+view : Model -> Browser.Document Msg
453+view model =
454+ { title = "elm.json"
455+ , body =
456+ [ span
457+ [ style "width" "calc(100% - 500px - 2em)"
458+ , style "position" "fixed"
459+ , style "top" "0"
460+ , style "left" "0"
461+ , style "bottom" "0"
462+ , style "overflow-x" "hidden"
463+ , style "overflow-y" "scroll"
464+ , style "filter" "blur(4px)"
465+ , style "white-space" "pre"
466+ , style "font-family" "monospace"
467+ ]
468+ [ text elmJson
469+ ]
470+ , viewEditPanel model
471+ ]
472+ }
473+
474+
475+viewEditPanel : Model -> Html Msg
476+viewEditPanel model =
477+ div
478+ [ style "width" "500px"
479+ , style "position" "fixed"
480+ , style "top" "0"
481+ , style "right" "0"
482+ , style "bottom" "0"
483+ , style "overflow-y" "scroll"
484+ , style "background-color" "white"
485+ , style "padding" "1em"
486+ ]
487+ [ node "style" [] [ text styles ]
488+ , div
489+ [ style "display" "flex"
490+ , style "justify-content" "space-between"
491+ ]
492+ [ viewMassUpdates
493+ , lazy3 viewUndoRedo model.status model.past model.future
494+ ]
495+ , div
496+ [ style "display" "flex"
497+ , style "justify-content" "space-between"
498+ , style "align-items" "center"
499+ ]
500+ [ h2 [] [ text "Dependencies" ]
501+ , Html.map SearchTouched <|
502+ lazy4 viewSearch searchDepsID "Package Search" model.registry model.search
503+ ]
504+ , lazy2 viewStatus model.origin model.status
505+ ]
506+
507+
508+viewMassUpdates : Html Msg
509+viewMassUpdates =
510+ div []
511+ [ text "Mass Updates: "
512+ , activeButton (Commit MassLock ) (text "LOCK")
513+ , activeButton (Commit MassPatch) (text "PATCH")
514+ , activeButton (Commit MassMinor) (text "MINOR")
515+ , activeButton (Commit MassMajor) (text "MAJOR")
516+ ]
517+
518+
519+viewUndoRedo : Status -> List Change -> List Change -> Html Msg
520+viewUndoRedo status past future =
521+ let
522+ hasNoPast =
523+ List.isEmpty past &&
524+ case status of
525+ Failure _ cs -> List.isEmpty cs
526+ Waiting _ cs -> List.isEmpty cs
527+ Success _ -> True
528+
529+ hasNoFuture =
530+ List.isEmpty future
531+ in
532+ div []
533+ [ if hasNoPast then inactiveButton undoIcon else activeButton Undo undoIcon
534+ , if hasNoFuture then inactiveButton redoIcon else activeButton Redo redoIcon
535+ ]
536+
537+
538+activeButton : msg -> Html msg -> Html msg
539+activeButton msg content =
540+ button [ class "button", onClick msg ] [ content ]
541+
542+
543+inactiveButton : Html msg -> Html msg
544+inactiveButton content =
545+ button [ class "button-inactive" ] [ content ]
546+
547+
548+
549+-- VIEW STATUS
550+
551+
552+viewStatus : Origin -> Status -> Html Msg
553+viewStatus origin status =
554+ let
555+ (directs, indirects) = viewStatusRows origin status
556+ in
557+ div []
558+ [ viewTable "Direct" <| Dict.toList directs
559+ , viewTable "Indirect" <| Dict.toList indirects
560+ ]
561+
562+
563+viewStatusRows : Origin -> Status -> (Dict String (Html Msg), Dict String (Html Msg))
564+viewStatusRows origin status =
565+ case status of
566+ Failure checkpoint changes ->
567+ let preview = toPreview origin checkpoint changes in
568+ ( Dict.map (lazy2 viewWaitingRow) preview.direct
569+ , Dict.map (lazy2 viewWaitingRow) preview.indirect
570+ )
571+
572+ Waiting checkpoint changes ->
573+ let preview = toPreview origin checkpoint changes in
574+ ( Dict.map (lazy2 viewWaitingRow) preview.direct
575+ , Dict.map (lazy2 viewWaitingRow) preview.indirect
576+ )
577+
578+ Success checkpoint ->
579+ ( Dict.map (lazy2 viewSuccessRow) checkpoint.direct
580+ , Dict.map (lazy2 viewSuccessRow) checkpoint.indirect
581+ )
582+
583+
584+viewSuccessRow : String -> Bounds -> Html Msg
585+viewSuccessRow pkg bounds =
586+ case bounds of
587+ New version newBounds ->
588+ viewRow pkg (RowNew version)
589+
590+ Old old new oldBounds ->
591+ viewRow pkg (RowOld old new)
592+
593+
594+viewWaitingRow : String -> PBounds -> Html Msg
595+viewWaitingRow pkg bounds =
596+ case bounds of
597+ PNew vsn newBounds ->
598+ viewRow pkg (RowNewGuess vsn)
599+
600+ POld old new oldBounds ->
601+ viewRow pkg (RowOldGuess old new)
602+
603+
604+
605+-- VIEW TABLE
606+
607+
608+viewTable : String -> List (String, Html Msg) -> Html Msg
609+viewTable title rows =
610+ table [ style "padding-bottom" "1em" ]
611+ [ viewColgroup
612+ , thead [] [ tr [] [ td [ class "table-title" ] [ text title ] ] ]
613+ , Keyed.node "tbody" [] rows
614+ ]
615+
616+
617+viewColgroup : Html msg
618+viewColgroup =
619+ colgroup []
620+ [ col [ style "width" "350px" ] []
621+ , col [ style "width" "50px" ] []
622+ , col [ style "width" "50px" ] []
623+ , col [ style "width" "50px" ] []
624+ ]
625+
626+
627+type RowInfo
628+ = RowNew Version
629+ | RowOld Version Version
630+ | RowNewGuess (Maybe Version)
631+ | RowOldGuess Version Version
632+
633+
634+viewRow : String -> RowInfo -> Html msg
635+viewRow pkg info =
636+ case info of
637+ RowNew vsn ->
638+ viewRowHelp pkg (text "") (text "") (viewVersion "black" vsn)
639+
640+ RowNewGuess Nothing ->
641+ viewRowHelp pkg (text "") (text "") (text "")
642+
643+ RowNewGuess (Just v) ->
644+ viewRowHelp pkg (text "") (text "") (viewVersion "#eeeeee" v)
645+
646+ RowOld old new ->
647+ if old == new
648+ then viewRowHelp pkg (text "") (text "") (viewVersion "#cccccc" new)
649+ else viewRowHelp pkg (viewVersion "#cccccc" old) (viewArrow "#cccccc") (viewVersion "black" new)
650+
651+ RowOldGuess old new ->
652+ if old == new
653+ then viewRowHelp pkg (text "") (text "") (viewVersion "#eeeeee" new)
654+ else viewRowHelp pkg (viewVersion "#eeeeee" old) (viewArrow "#eeeeee") (viewVersion "#eeeeee" new)
655+
656+
657+viewRowHelp : String -> Html msg -> Html msg -> Html msg -> Html msg
658+viewRowHelp pkg oldHtml arrowHtml newHtml =
659+ tr []
660+ [ td [ style "font-family" "monospace" ] [ text pkg ]
661+ , td [ style "text-align" "right" ] [ oldHtml ]
662+ , td [ style "text-align" "center" ] [ arrowHtml ]
663+ , td [ ] [ newHtml ]
664+ ]
665+
666+
667+viewVersion : String -> Version -> Html msg
668+viewVersion color (Version x y z) =
669+ span
670+ [ style "font-family" "monospace"
671+ , style "color" color
672+ , style "transition" "color 1s"
673+ ]
674+ [ text (v2s x y z)
675+ ]
676+
677+
678+viewArrow : String -> Html msg
679+viewArrow color =
680+ span
681+ [ style "color" color
682+ , style "transition" "color 1s"
683+ ]
684+ [ text "→"
685+ ]
686+
687+
688+
689+-- REGISTRY
690+
691+
692+type alias Registry = Dict String (List Char)
693+
694+
695+toRegistry : List String -> Registry
696+toRegistry packages =
697+ Dict.fromList (List.map (\n -> (n, toSearchChars n)) packages)
698+
699+
700+toSearchChars : String -> List Char
701+toSearchChars string =
702+ String.toList (String.toLower string)
703+
704+
705+registryTODO : Registry
706+registryTODO =
707+ toRegistry
708+ [ "elm-explorations/test"
709+ , "elm-explorations/markdown"
710+ , "elm/browser"
711+ , "elm/bytes"
712+ , "elm/core"
713+ , "elm/file"
714+ , "elm/html"
715+ , "elm/http"
716+ , "elm/json"
717+ , "elm/project-metadata-utils"
718+ , "elm/svg"
719+ , "elm/parser"
720+ , "elm/time"
721+ , "elm/url"
722+ , "elm/virtual-dom"
723+ ]
724+
725+
726+
727+-- SEARCH
728+
729+
730+type alias Search =
731+ { query : String
732+ , focus : Maybe Int
733+ }
734+
735+
736+type SearchMsg
737+ = SChanged String
738+ | SUp
739+ | SDown
740+ | SFocus
741+ | SBlur
742+ | SEscape
743+ | SEnter
744+ | SClickAdd
745+ | SClickMatch String
746+
747+
748+type SearchNext
749+ = SNone
750+ | SUpdate Search
751+ | SManualBlur Search
752+ | SAdd String
753+
754+
755+updateSearch : Registry -> SearchMsg -> Search -> SearchNext
756+updateSearch registry msg search =
757+ case msg of
758+ SChanged query ->
759+ SUpdate { query = query, focus = Just 0 }
760+
761+ SUp ->
762+ let
763+ newFocus = Maybe.map (\n -> Basics.max 0 (n - 1)) search.focus
764+ in
765+ SUpdate { search | focus = newFocus }
766+
767+ SDown ->
768+ let
769+ numMatches = List.length (getBestMatches search.query registry)
770+ newFocus = Maybe.map (\n -> Basics.min numMatches (n + 1)) search.focus
771+ in
772+ SUpdate { search | focus = newFocus }
773+
774+ SFocus ->
775+ SUpdate { search | focus = Just 0 }
776+
777+ SBlur ->
778+ SUpdate { search | focus = Nothing }
779+
780+ SEscape ->
781+ SManualBlur { search | focus = Nothing }
782+
783+ SEnter ->
784+ case search.focus of
785+ Nothing ->
786+ SNone
787+
788+ Just 0 ->
789+ if Dict.member search.query registry
790+ then SAdd search.query
791+ else SNone
792+
793+ Just n ->
794+ case getMatch n (getBestMatches search.query registry) of
795+ Just match -> SUpdate { query = match, focus = Just 0 }
796+ Nothing -> SNone
797+
798+ SClickAdd ->
799+ if Dict.member search.query registry
800+ then SAdd search.query
801+ else SNone
802+
803+ SClickMatch match ->
804+ SUpdate { query = match, focus = Just 0 }
805+
806+
807+getMatch : Int -> List (Int, String) -> Maybe String
808+getMatch n matches =
809+ case matches of
810+ [] ->
811+ Nothing
812+
813+ (_, match) :: worseMatches ->
814+ if n <= 0 then
815+ Nothing
816+ else if n == 1 then
817+ Just match
818+ else
819+ getMatch (n-1) worseMatches
820+
821+
822+
823+-- VIEW SEARCH
824+
825+
826+searchDepsID : String
827+searchDepsID = "search-deps"
828+
829+
830+searchTestID : String
831+searchTestID = "search-test"
832+
833+
834+viewSearch : String -> String -> Registry -> Search -> Html SearchMsg
835+viewSearch searchID ghostText registry search =
836+ div [ style "position" "relative" ]
837+ [ lazy3 viewSearchQuery searchID ghostText search.query
838+ , lazy2 viewSearchAdd search.query registry
839+ , lazy3 viewSearchMatches search.query search.focus registry
840+ ]
841+
842+
843+viewSearchAdd : String -> Registry -> Html SearchMsg
844+viewSearchAdd query registry =
845+ if Dict.member query registry then
846+ activeButton SClickAdd (text "Add")
847+ else
848+ inactiveButton (text "Add")
849+
850+
851+viewSearchMatches : String -> Maybe Int -> Registry -> Html SearchMsg
852+viewSearchMatches query focus registry =
853+ case focus of
854+ Nothing ->
855+ text ""
856+
857+ Just n ->
858+ if String.isEmpty query
859+ then text ""
860+ else
861+ case getBestMatches query registry of
862+ [] ->
863+ text ""
864+
865+ bestMatches ->
866+ div [ class "search-matches" ] <|
867+ List.indexedMap (viewSearchMatch (n-1)) bestMatches
868+
869+
870+viewSearchMatch : Int -> Int -> (Int, String) -> Html SearchMsg
871+viewSearchMatch target actual (_, name) =
872+ div
873+ [ class "search-match"
874+ , classList [("search-match-focused", target == actual)]
875+ , onClick (SClickMatch name)
876+ ]
877+ [ div [ style "padding" "0.5em 1em" ] [ text name ]
878+ ]
879+
880+
881+
882+-- VIEW SEARCH QUERY
883+
884+
885+viewSearchQuery : String -> String -> String -> Html SearchMsg
886+viewSearchQuery searchID ghostText query =
887+ input
888+ [ type_ "text"
889+ , id searchID
890+ , placeholder ghostText
891+ , autocomplete False
892+ , class "search-input"
893+ , value query
894+ , onInput SChanged
895+ , on "keydown" keyDecoder
896+ , onFocus SFocus
897+ , onBlur SBlur
898+ ]
899+ []
900+
901+
902+keyDecoder : D.Decoder SearchMsg
903+keyDecoder =
904+ let
905+ check up down enter escape value =
906+ if value == up then
907+ D.succeed SUp
908+ else if value == down then
909+ D.succeed SDown
910+ else if value == enter then
911+ D.succeed SEnter
912+ else if value == escape then
913+ D.succeed SEscape
914+ else
915+ D.fail "not up or down"
916+ in
917+ D.oneOf
918+ [ D.field "key" D.string
919+ |> D.andThen (check "ArrowUp" "ArrowDown" "Enter" "Escape")
920+ , D.field "keyCode" D.int
921+ |> D.andThen (check 38 40 13 27)
922+ ]
923+
924+
925+
926+-- MATCHES
927+
928+
929+getBestMatches : String -> Registry -> List (Int, String)
930+getBestMatches query registry =
931+ Dict.foldl (addMatch (toSearchChars query)) [] registry
932+
933+
934+addMatch : List Char -> String -> List Char -> List (Int, String) -> List (Int, String)
935+addMatch queryChars targetName targetChars bestMatches =
936+ case distance 0 queryChars targetChars of
937+ Nothing ->
938+ bestMatches
939+
940+ Just dist ->
941+ insert 4 targetName dist bestMatches
942+
943+
944+insert : Int -> String -> Int -> List (Int, String) -> List (Int, String)
945+insert limit name dist bestMatches =
946+ if limit <= 0 then
947+ bestMatches
948+ else
949+ case bestMatches of
950+ [] ->
951+ [ (dist, name) ]
952+
953+ ((bestDist, bestName) as best) :: worseMatches ->
954+ if dist < bestDist then
955+ (dist, name) :: List.take (limit - 1) bestMatches
956+ else
957+ best :: insert (limit - 1) name dist worseMatches
958+
959+
960+distance : Int -> List Char -> List Char -> Maybe Int
961+distance dist queryChars targetChars =
962+ case queryChars of
963+ [] ->
964+ case dist + List.length targetChars of
965+ 0 -> Nothing
966+ n -> Just n
967+
968+ qc :: qcs ->
969+ case targetChars of
970+ [] ->
971+ Nothing
972+
973+ tc :: tcs ->
974+ if qc == tc then
975+ distance dist qcs tcs
976+ else
977+ distance (dist + 1) queryChars tcs
978+
979+
980+
981+-- ICONS
982+
983+
984+undoIcon : Html msg
985+undoIcon =
986+ icon "M255.545 8c-66.269.119-126.438 26.233-170.86 68.685L48.971 40.971C33.851 25.851 8 36.559 8 57.941V192c0 13.255 10.745 24 24 24h134.059c21.382 0 32.09-25.851 16.971-40.971l-41.75-41.75c30.864-28.899 70.801-44.907 113.23-45.273 92.398-.798 170.283 73.977 169.484 169.442C423.236 348.009 349.816 424 256 424c-41.127 0-79.997-14.678-110.63-41.556-4.743-4.161-11.906-3.908-16.368.553L89.34 422.659c-4.872 4.872-4.631 12.815.482 17.433C133.798 479.813 192.074 504 256 504c136.966 0 247.999-111.033 248-247.998C504.001 119.193 392.354 7.755 255.545 8z"
987+
988+
989+redoIcon : Html msg
990+redoIcon =
991+ icon "M256.455 8c66.269.119 126.437 26.233 170.859 68.685l35.715-35.715C478.149 25.851 504 36.559 504 57.941V192c0 13.255-10.745 24-24 24H345.941c-21.382 0-32.09-25.851-16.971-40.971l41.75-41.75c-30.864-28.899-70.801-44.907-113.23-45.273-92.398-.798-170.283 73.977-169.484 169.442C88.764 348.009 162.184 424 256 424c41.127 0 79.997-14.678 110.629-41.556 4.743-4.161 11.906-3.908 16.368.553l39.662 39.662c4.872 4.872 4.631 12.815-.482 17.433C378.202 479.813 319.926 504 256 504 119.034 504 8.001 392.967 8 256.002 7.999 119.193 119.646 7.755 256.455 8z"
992+
993+
994+unlockIcon : Html msg
995+unlockIcon =
996+ icon "M423.5 0C339.5.3 272 69.5 272 153.5V224H48c-26.5 0-48 21.5-48 48v192c0 26.5 21.5 48 48 48h352c26.5 0 48-21.5 48-48V272c0-26.5-21.5-48-48-48h-48v-71.1c0-39.6 31.7-72.5 71.3-72.9 40-.4 72.7 32.1 72.7 72v80c0 13.3 10.7 24 24 24h32c13.3 0 24-10.7 24-24v-80C576 68 507.5-.3 423.5 0z"
997+
998+
999+lockIcon : Html msg
1000+lockIcon =
1001+ icon "M400 224h-24v-72C376 68.2 307.8 0 224 0S72 68.2 72 152v72H48c-26.5 0-48 21.5-48 48v192c0 26.5 21.5 48 48 48h352c26.5 0 48-21.5 48-48V272c0-26.5-21.5-48-48-48zm-104 0H152v-72c0-39.7 32.3-72 72-72s72 32.3 72 72v72z"
1002+
1003+
1004+icon : String -> Html msg
1005+icon path =
1006+ div
1007+ [ style "display" "inline-flex"
1008+ , style "align-self" "center"
1009+ , style "top" ".125em"
1010+ , style "position" "relative"
1011+ ]
1012+ [ Svg.svg
1013+ [ S.viewBox "0 0 512 512"
1014+ , S.width "1em"
1015+ , S.height "1em"
1016+ ]
1017+ [ Svg.path
1018+ [ S.fill "currentColor"
1019+ , S.d path
1020+ ]
1021+ []
1022+ ]
1023+ ]
1024+
1025+
1026+
1027+-- VERSIONS
1028+
1029+
1030+type Version =
1031+ Version Int Int Int
1032+
1033+
1034+
1035+-- ENCODE CONSTRAINTS
1036+
1037+
1038+encodeConstraint : PBounds -> E.Value
1039+encodeConstraint bounds =
1040+ case bounds of
1041+ POld (Version x y z) _ oldBounds ->
1042+ case oldBounds of
1043+ OLocked -> E.string <| v2s x y z ++ " <= v < " ++ v2s x y (z + 1)
1044+ OPatch -> E.string <| v2s x y z ++ " <= v < " ++ v2s x y max16
1045+ OMinor -> E.string <| v2s x y z ++ " <= v < " ++ v2s x max16 0
1046+ OMajor -> E.string <| v2s x y z ++ " <= v < " ++ v2s max16 0 0
1047+ OAny -> encodeAny
1048+ OCustom c -> Constraint.encode c
1049+
1050+ PNew _ newBounds ->
1051+ case newBounds of
1052+ NAny -> encodeAny
1053+ NCustom c -> Constraint.encode c
1054+
1055+
1056+encodeAny : E.Value
1057+encodeAny =
1058+ E.string <| v2s 1 0 0 ++ " <= v <= " ++ v2s max16 max16 max16
1059+
1060+
1061+max16 : Int
1062+max16 =
1063+ 65535
1064+
1065+
1066+v2s : Int -> Int -> Int -> String
1067+v2s major minor patch =
1068+ String.fromInt major ++ "." ++ String.fromInt minor ++ "." ++ String.fromInt patch
1069+
1070+
1071+
1072+-- DECODE SOLUTION
1073+
1074+
1075+solutionDecoder : D.Decoder (Dict String Version)
1076+solutionDecoder =
1077+ D.dict versionDecoder
1078+
1079+
1080+versionDecoder : D.Decoder Version
1081+versionDecoder =
1082+ let
1083+ toVersion str =
1084+ case fromString str of
1085+ Just vsn -> D.succeed vsn
1086+ Nothing -> D.fail "invalid version number"
1087+ in
1088+ D.andThen toVersion D.string
1089+
1090+
1091+fromString : String -> Maybe Version
1092+fromString string =
1093+ case List.map String.toInt (String.split "." string) of
1094+ [Just major, Just minor, Just patch] ->
1095+ fromStringHelp major minor patch
1096+
1097+ _ ->
1098+ Nothing
1099+
1100+
1101+fromStringHelp : Int -> Int -> Int -> Maybe Version
1102+fromStringHelp major minor patch =
1103+ if major >= 0 && minor >= 0 && patch >= 0 then
1104+ Just (Version major minor patch)
1105+ else
1106+ Nothing
1107+
1108+
1109+
1110+-- TODO delete everything below here
1111+
1112+
1113+styles : String
1114+styles = """
1115+body {
1116+ font-family: sans-serif;
1117+ font-size: 16px;
1118+ background-color: #cccccc;
1119+}
1120+.search-input {
1121+ padding: 0.5em 1em;
1122+ border: 1px solid #cccccc;
1123+ border-radius: 2px;
1124+}
1125+.search-matches {
1126+ position: absolute;
1127+ top: 100%;
1128+ left: 0;
1129+ right: 0;
1130+ background-color: white;
1131+}
1132+.search-match {
1133+ border-left: 1px solid #cccccc;
1134+ border-right: 1px solid #cccccc;
1135+ border-bottom: 1px solid #cccccc;
1136+}
1137+.search-match:hover {
1138+ background-color: #eeeeee;
1139+ cursor: pointer;
1140+}
1141+.search-match-focused {
1142+ background-color: #60B5CC !important;
1143+ border-color: #60B5CC;
1144+ color: white;
1145+}
1146+.button {
1147+ padding: 0.5em 1em;
1148+ border: 1px solid #60B5CC;
1149+ background-color: white;
1150+ border-radius: 2px;
1151+ color: #60B5CC;
1152+}
1153+.button:hover {
1154+ color: white;
1155+ background-color: #60B5CC;
1156+}
1157+.button:active {
1158+ color: white;
1159+ border-color: #5A6378;
1160+ background-color: #5A6378;
1161+}
1162+.button-inactive {
1163+ padding: 0.5em 1em;
1164+ border: 1px solid #cccccc;
1165+ background-color: white;
1166+ border-radius: 2px;
1167+ color: #cccccc;
1168+}
1169+.table-title {
1170+ text-transform: uppercase;
1171+ color: #cccccc;
1172+ font-size: .75em;
1173+}
1174+"""
1175+
1176+
1177+elmJson : String
1178+elmJson = """
1179+{
1180+ "type": "application",
1181+ "source-directories": [
1182+ "src"
1183+ ],
1184+ "elm-version": "0.19.0",
1185+ "dependencies": {
1186+ "direct": {
1187+ "elm/browser": "1.0.1",
1188+ "elm/core": "1.0.2",
1189+ "elm/html": "1.0.0",
1190+ "elm/http": "2.0.0",
1191+ "elm/json": "1.1.2",
1192+ "elm/project-metadata-utils": "1.0.0",
1193+ "elm/svg": "1.0.1",
1194+ "elm-explorations/markdown": "1.0.0"
1195+ },
1196+ "indirect": {
1197+ "elm/bytes": "1.0.7",
1198+ "elm/file": "1.0.1",
1199+ "elm/parser": "1.1.0",
1200+ "elm/time": "1.0.0",
1201+ "elm/url": "1.0.0",
1202+ "elm/virtual-dom": "1.0.2"
1203+ }
1204+ },
1205+ "test-dependencies": {
1206+ "direct": {},
1207+ "indirect": {}
1208+ }
1209+}
1210+"""