-
Notifications
You must be signed in to change notification settings - Fork 5
/
Main.elm
184 lines (141 loc) · 7.24 KB
/
Main.elm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
port module Main exposing (Model(..), Msg(..), init, main, mapTEA, subscriptions, switchSubAppsIfNeeded, update, view)
import Browser
import Html exposing (Html, a, button, div, img, nav, p, text)
import Html.Attributes exposing (alt, attribute, class, href, src, style, target)
import Html.Events exposing (onClick)
import File exposing (File)
import File.Download as Download
import File.Select as Select
import Json.Decode as Decode
import Json.Encode as Encode
import Task
import IdeaFight.Compete as Compete
import IdeaFight.LandingPage as LandingPage
type Model
= LandingPageModel LandingPage.Model
| CompeteModel (Compete.Model String)
| LoadOldState Model
type Msg
= LandingPageMsg LandingPage.Msg
| CompeteMsg (Compete.Msg String)
| PerformImportMsg
| PerformExportMsg
| FileSelectedForImportMsg File
| FileLoadedMsg String
| LoadOldModelMsg
| IgnoreOldModelMsg
mapTEA : (modela -> modelb) -> (msga -> msgb) -> ( modela, Cmd msga ) -> ( modelb, Cmd msgb )
mapTEA modelTransform msgTransform ( oldModel, oldCmd ) =
( modelTransform oldModel, Cmd.map msgTransform oldCmd )
init : Maybe String -> ( Model, Cmd Msg )
init previousSessionState =
case previousSessionState of
Nothing -> mapTEA LandingPageModel LandingPageMsg <| LandingPage.init
Just serializedState -> case decodeModel serializedState of
Ok state -> (LoadOldState state, Cmd.none)
Err _ -> mapTEA LandingPageModel LandingPageMsg <| LandingPage.init -- XXX inform the user?
switchSubAppsIfNeeded : ( Model, Cmd Msg ) -> ( Model, Cmd Msg )
switchSubAppsIfNeeded ( model, cmd ) =
case model of
LandingPageModel ( contents, True ) ->
mapTEA CompeteModel CompeteMsg <| Compete.init <| String.lines <| String.trim contents
_ ->
( model, cmd )
ifType : String -> Decode.Decoder a -> Decode.Decoder a
ifType expectedType successDecoder = Decode.field "__type__" Decode.string |> Decode.andThen (\gotType -> if gotType == expectedType then successDecoder else Decode.fail "type didn't match")
decodeLandingPageModel : Decode.Decoder Model
decodeLandingPageModel = ifType "landing_page" LandingPage.decodeModel |> Decode.map LandingPageModel
decodeCompeteModel : Decode.Decoder Model
decodeCompeteModel = ifType "compete" Compete.decodeModel |> Decode.map CompeteModel
-- XXX map the error
decodeModel : String -> Result Decode.Error Model
decodeModel =
let modelDecoder = Decode.oneOf [ decodeLandingPageModel, decodeCompeteModel ]
in Decode.decodeString modelDecoder
encodeModel : Model -> Encode.Value
encodeModel model =
case model of
LandingPageModel landing_model -> Encode.object <| ("__type__", Encode.string "landing_page") :: LandingPage.encodeModel landing_model
CompeteModel compete_model -> Encode.object <| ("__type__", Encode.string "compete") :: Compete.encodeModel compete_model
LoadOldState innerModel -> encodeModel innerModel
update_ : Msg -> Model -> ( Model, Cmd Msg )
update_ msg model =
case ( msg, model ) of
( LandingPageMsg landing_msg, LandingPageModel landing_model ) ->
switchSubAppsIfNeeded <| mapTEA LandingPageModel LandingPageMsg <| LandingPage.update landing_msg landing_model
( CompeteMsg compete_msg, CompeteModel compete_model ) ->
mapTEA CompeteModel CompeteMsg <| Compete.update compete_msg compete_model
( PerformImportMsg, _ ) ->
( model, Select.file ["text/json"] FileSelectedForImportMsg )
( PerformExportMsg, _ ) ->
let serializedModel = Encode.encode 0 <| encodeModel model
downloadCmd = Download.string "idea-fight.json" "application/json" serializedModel
in ( model, downloadCmd )
( FileSelectedForImportMsg file, _ ) ->
( model, Task.perform FileLoadedMsg <| File.toString file)
( FileLoadedMsg content, _ ) ->
case decodeModel content of
Ok newModel -> (newModel, Cmd.none)
Err err -> let _ = Debug.log "got error: " (Decode.errorToString err) in (model, Cmd.none) -- XXX handle me properly
( LoadOldModelMsg, LoadOldState oldModel) ->
( oldModel, Cmd.none )
( IgnoreOldModelMsg, _) ->
init Nothing
( _, _ ) ->
(model, Cmd.none) -- This should be impossible!
update : Msg -> Model -> ( Model, Cmd Msg )
update msg model =
let (newModel, newMsg) = update_ msg model
serializedModel = Encode.encode 0 <| encodeModel newModel
saveMsg = saveState serializedModel
in (newModel, Cmd.batch [newMsg, saveMsg])
subscriptions : Model -> Sub Msg
subscriptions model =
case model of
LandingPageModel landing_model ->
Sub.map LandingPageMsg <| LandingPage.subscriptions landing_model
CompeteModel compete_model ->
Sub.map CompeteMsg <| Compete.subscriptions compete_model
LoadOldState old_model ->
Sub.none
importButton : Html Msg
importButton = button [ onClick PerformImportMsg, class "button-primary" ] [ text "Import" ]
exportButton : Html Msg
exportButton = button [ onClick PerformExportMsg, class "button-primary" ] [ text "Export" ]
repoLocation : String
repoLocation = "https://github.com/hoelzro/idea-fight"
ribbonImageLocation : String
ribbonImageLocation = "https://camo.githubusercontent.com/e7bbb0521b397edbd5fe43e7f760759336b5e05f/68747470733a2f2f73332e616d617a6f6e6177732e636f6d2f6769746875622f726962626f6e732f666f726b6d655f72696768745f677265656e5f3030373230302e706e67"
canonicalRibbonImageLocation : String
canonicalRibbonImageLocation = "https://s3.amazonaws.com/github/ribbons/forkme_right_green_007200.png"
view : Model -> Html Msg
view model =
let
navbar = nav [] [ importButton, exportButton ]
ribbonImage = img [style "position" "absolute", style "top" "0", style "right" "0", style "border" "0", src ribbonImageLocation, alt "Fork me on GitHub", attribute "data-canonical-src" canonicalRibbonImageLocation ] []
ribbonAnchor = a [href repoLocation, target "_blank" ] [ribbonImage]
innerView = case model of
LandingPageModel landing_model ->
let inner = Html.map LandingPageMsg <| LandingPage.view landing_model
in div [] [ inner ]
CompeteModel compete_model ->
let inner = Html.map CompeteMsg <| Compete.view Html.text Html.text compete_model
in div [] [ inner ]
LoadOldState oldModel ->
let msg = p [] [text "It seems you have returned after an unfinished session; would you like to restore the previous session's state?"]
loadButton = button [ onClick LoadOldModelMsg, class "button-primary" ] [text "Yes"]
ignoreButton = button [ onClick IgnoreOldModelMsg, class "button-primary" ] [text "No"]
in div [] [ msg, loadButton, ignoreButton ]
oneHalfColumnDiv = div [class "one-half", class "column", style "margin-top" "25px"] [innerView]
rowDiv = div [class "row"] [oneHalfColumnDiv]
containerDiv = div [class "container"] [rowDiv]
in div [] [ navbar, ribbonAnchor , containerDiv ]
port saveState : String -> Cmd msg
main : Program (Maybe String) Model Msg
main =
Browser.element
{ init = init
, update = update
, subscriptions = subscriptions
, view = view
}