-
-
Notifications
You must be signed in to change notification settings - Fork 18
/
Main.hs
146 lines (136 loc) · 3.79 KB
/
Main.hs
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
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Main
( main,
)
where
import Control.Lens ((%~), makeClassy_)
import Control.Monad (void)
import Control.Monad.Trans (lift)
import Data.Function ((&))
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import qualified Data.Text as Text
import qualified Data.Vector as Vector
import FF
( filterTasksByStatus,
fromRgaM,
getDataDir,
loadAllNotes,
noDataDirectoryMessage,
viewNote,
)
import FF.Config (loadConfig)
import FF.Types
( Entity (Entity),
EntityView,
Note (Note),
NoteId,
NoteStatus (TaskStatus),
Status (Active),
View (NoteView, note),
)
import qualified FF.Types
import qualified GI.Gtk as Gtk
import GI.Gtk.Declarative
( Attribute ((:=)),
BoxChild,
bin,
container,
on,
widget,
)
import GI.Gtk.Declarative.App.Simple
( App (App),
AppView,
Transition (Exit, Transition),
run,
)
import qualified GI.Gtk.Declarative.App.Simple
import Pipes (Producer, each)
import RON.Storage.FS (runStorage)
import qualified RON.Storage.FS as StorageFS
newtype State = State {tasks :: Map NoteId (View Note)}
makeClassy_ ''State
data Event
= Close
| UpsertTask (EntityView Note)
view :: State -> AppView Gtk.Window Event
view State {tasks} =
bin Gtk.Window
[ #title := "ff-gtk",
#heightRequest := 300,
#widthRequest := 400,
on #deleteEvent $ const (True, Close)
]
mainWidget
where
mainWidget = bin Gtk.ScrolledWindow [] taskList
taskList =
-- BoxChild defaultBoxChildProperties{expand = True, fill = True} $
container Gtk.Box
[#orientation := Gtk.OrientationVertical]
( Vector.fromList
[ taskWidget $ Entity noteId note
| (noteId, note) <- Map.assocs tasks
]
)
taskWidget :: EntityView Note -> BoxChild Event
taskWidget Entity {entityVal} =
widget Gtk.Label
[ #halign := Gtk.AlignStart,
#label := (if isActive then id else strike) (Text.pack noteText),
-- , #useMarkup := True
#wrap := True
]
where
NoteView {note = Note {note_status, note_text}} = entityVal
noteText = fromRgaM note_text
isActive = note_status == Just (TaskStatus Active)
strike text = "<s>" <> text <> "</s>"
-- newTaskForm = widget Gtk.Entry
-- [ #text := currentText
-- , #placeholderText := "What needs to be done?"
-- , onM #changed $ fmap NewTodoChanged . Gtk.entryGetText
-- , on #activate NewTodoSubmitted
-- ]
--
update :: State -> Event -> Transition State Event
update st = \case
Close -> Exit
UpsertTask Entity {entityId, entityVal} ->
Transition (st & _tasks %~ Map.insert entityId entityVal) (pure Nothing)
main :: IO ()
main = do
path <- getDataDirOrFail
storage <- StorageFS.newHandle path
void $
run App{
view,
update,
initialState = State {tasks = []},
inputs = [
initiallyLoadActiveTasks storage
-- TODO , listenToChanges
]
}
initiallyLoadActiveTasks :: StorageFS.Handle -> Producer Event IO ()
initiallyLoadActiveTasks storage = do
activeTasks <-
lift $ runStorage storage $ do
notes <- loadAllNotes
let filtered = filterTasksByStatus Active notes
traverse viewNote filtered
each $ map UpsertTask activeTasks
getDataDirOrFail :: IO FilePath
getDataDirOrFail = do
cfg <- loadConfig
dataDir <- getDataDir cfg
case dataDir of
Nothing -> fail noDataDirectoryMessage
Just path -> pure path