~jackwines/fast-bronze

ref: 93636f0910a6e327d6530e2d212388c2e5597240 fast-bronze/src/Main.hs -rw-r--r-- 13.2 KiB
93636f09 — Jack Wines more CI fixes 1 year, 23 days ago
                                                                                
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
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
module Main where
import           Control.Monad ( void )
import           Data.Function ( (&) )
import           Data.Text ( Text )
import           Pipes
import qualified Pipes.Extras as Pipes

import           GI.Gtk (ListBoxRow,  Button(..)
                                                , Grid(..)
                                                , Box(..)
                                                , Label(..)
                                                , Window(..)
                                                , Grid(..)
                                                )
import           Control.Concurrent.Async ( async )
import qualified GI.Gtk as Gtk
import           GI.Gtk.Declarative
import           GI.Gtk.Declarative.App.Simple
import           GI.Gtk.Declarative.Container.Grid
import qualified GI.Gdk as Gdk
import qualified GI.Gdk.Structs.EventKey as EK
import qualified Data.Text as T
import qualified System.Posix.Files as F
import           System.IO
import qualified Data.GI.Base.ShortPrelude as GIB
import qualified System.Posix as P
import qualified System.Directory as D
import qualified Data.Char as C
import           Data.Maybe
import qualified Debug.Trace as T
import qualified Data.ByteString as BS
import qualified Data.Vector as Vec
import qualified Control.Monad.IO.Class as M
import qualified Control.Applicative as A
import           Catalog
import qualified ListZipper as LZ
import Data.List as L
import GI.Gtk.Objects.ListBox (ListBox(ListBox))


data Event = Closed | KeyPressed Char | Delete | Tab | Enter | Up | Down | Left | Right | ReplaceCatalog [Cataloged]

data AppState = AppState {
  catalog :: [Cataloged],
  firstCatalogs :: Maybe (LZ.ListZipper Cataloged),
  currActions :: Maybe (LZ.ListZipper Action),
  secondCatalogs :: Maybe (LZ.ListZipper Cataloged), -- first selected catalog goes here if the action wants a second thing
  focus :: Focus,
  searchText :: T.Text
                         }

-- what should be highlighted? The catalog or the actions
data Focus = Action | Catalog | SecondCatalog deriving (Show, Eq)

view' :: AppState -> AppView Window Event
view' s =
  bin
      Window
      [ #title := (maybe "fast-bronze" dirPath $ searchCatalog s)
      , on #deleteEvent (const (True, Closed))
      , onM #keyPressEvent handleKeyPress
      , #widthRequest := 600
      , #heightRequest := if actionRequiresSecondCatalog then 600 else 400
      ]
    $ container
      Grid []
        ([
          GridChild { -- the current catalog panel. Can be either on top or on bottom
            properties = defaultGridChildProperties {
              height = 1,
              width = 6,
              topAttach = 0,
              leftAttach = 2
              },
            child = widget Label [
              -- #widthRequest := 400,
              -- #heightRequest := 200,
              #label := topBoxText,
              #hexpand := True,
              #vexpand := True,
              classes firstCatalogClasses
              ]
          },
          GridChild { -- the actions panel
            properties = defaultGridChildProperties {
              height = 1,
              width = 6,
              topAttach = 1,
              leftAttach = 2
            },
            child = widget Label [
              -- #widthRequest := 400,
              -- #heightRequest := 200,
              #label := bottomBoxText,
              #hexpand := True,
              #vexpand := True,
              classes actionClasses
              ]
          },
          GridChild { -- the current matches panel
            properties = defaultGridChildProperties {
              height = 2,
              width = 1,
              topAttach = 0,
              leftAttach = 8
            },
            child =  otherOptions LZ.after
          }
        ] Vec.++ (if not actionRequiresSecondCatalog then [] else
          [GridChild { -- the first catalog actions panel is parked here
            properties = defaultGridChildProperties {
              height = 1,
              width = 6,
              topAttach = 3,
              leftAttach = 2
            },
            child = widget Label [
              -- #widthRequest := 400,
              -- #heightRequest := 200,
              #label := (formatBoxLabel . fmap LZ.focus . secondCatalogs $ s),
              #hexpand := True,
              #vexpand := True,
              classes secondCatalogClasses
            ]
          }])
        )

      where

        otherOptions zipperF = container ListBox noExpand . Vec.fromList . take 23 . map (searchListWidget . T.take 10) . maybe [" "] zipperF $ case focus s of
          Main.Action ->  LZ.map searchString <$> currActions s
          Catalog -> LZ.map searchString <$> firstCatalogs s
          SecondCatalog -> LZ.map searchString <$> secondCatalogs s


        noExpand = [#hexpand := False, #vexpand := False]--, #heightRequest := 400, #widthRequest := 100]

        searchListWidget txt = bin Gtk.ListBoxRow [] $ widget Label [
                #label := txt,
                #hexpand := True,
                #vexpand := False,
                #widthRequest := 100
              ]

        bottomBoxText :: T.Text
        bottomBoxText = formatBoxLabel . searchAction $ s

        topBoxText :: T.Text
        topBoxText =  formatBoxLabel . searchCatalog $ s

        actionRequiresSecondCatalog :: Bool
        actionRequiresSecondCatalog = case ioAction . LZ.focus <$> currActions s of
          (Just (TwoParam _)) -> True
          _ -> False

        formatBoxLabel :: Searchable a => Maybe a -> T.Text
        formatBoxLabel = maybe "" (T.take 20 . searchString)

        firstCatalogClasses :: [Text]
        firstCatalogClasses = case focus s of
          Catalog -> ["selected"]
          _ -> ["unselected"]

        actionClasses :: [Text]
        actionClasses = case focus s of
          Main.Action -> ["selected"]
          _ -> ["unselected"]

        secondCatalogClasses :: [Text]
        secondCatalogClasses = case focus s of
          SecondCatalog -> ["selected"]
          _ -> ["unselected"]

update' :: AppState -> Event -> Transition AppState Event
update' _ Closed = Exit
-- remove everything on delete
update' s Delete = Transition (resetCurrZipper s) (return Nothing)
-- flip focus to bottom or top on tab
update' s Tab = Transition (moveFocusDown s) (return Nothing)
-- move up or down the catalog/actions
update' s Up =   Transition (selectedZipperRight s) (return Nothing)
update' s Down = Transition (selectedZipperLeft  s) (return Nothing)
-- move right, into the current directory
update' s Main.Right = Transition s $
  case (firstCatalogs s, focus s) of
    (Just (LZ.ListZipper _ curr _ ), Catalog) -> do
      let currPath :: String = T.unpack . dirPath $ curr
      isDir <- P.isDirectory <$> P.getFileStatus currPath
      if not isDir then return Nothing else do
        childPaths <- filterHiddenFiles <$> (listAbsoluteDir . T.unpack . dirPath $ curr)
        childIsDirs <- mapM (fmap P.isDirectory . P.getFileStatus) childPaths
        return . Just . ReplaceCatalog $ zipWith dirToCatalog childPaths childIsDirs
    _ -> return Nothing
update' s Main.Left = Transition s $
  case (firstCatalogs s, focus s) of
    (Just (LZ.ListZipper _ curr _ ), Catalog) -> do
      let currPath = getParentDir . T.unpack . dirPath $ curr
      if currPath == "/" || currPath == "" then return Nothing else do
        let currPathParent = getParentDir currPath
        childPaths <- filter (/= currPathParent) . filterHiddenFiles <$> listAbsoluteDir currPathParent
        childIsDirs <- mapM (fmap P.isDirectory . P.getFileStatus) childPaths
        currPathParentAsCatalog <- dirToCatalog currPath . P.isDirectory <$> P.getFileStatus currPath
        return . Just . ReplaceCatalog $ currPathParentAsCatalog : zipWith dirToCatalog childPaths childIsDirs -- we place it at the start so it's the selected item
    _ -> return Nothing
update' s (ReplaceCatalog c) = Transition (replaceCatalog s c) (return Nothing)
update' s Enter =
  Transition s $
    case (ioAction <$> searchAction s, LZ.focus <$> secondCatalogs s, searchCatalog s) of
      (Just (OneParam f), Nothing, Just catalogItem) -> do
        f catalogItem
        return $ Just Closed
      (Just (TwoParam f), Just secondCatalogItem, Just firstCatalogItem) -> do
        f firstCatalogItem secondCatalogItem
        return $ Just Closed
      (_, _, _) -> return Nothing
update' s (KeyPressed c) = Transition (applySearchFilter s searchText') (return Nothing)
  where
    searchText' = T.snoc (searchText s) c

replaceCatalog s xs = case focus s of
  Main.Action -> s
  Catalog -> s {firstCatalogs = LZ.fromList xs, searchText = ""}
  SecondCatalog -> s {secondCatalogs = LZ.fromList xs, searchText = ""}

listAbsoluteDir dir = map (\xs -> dir ++ '/' : xs) <$> D.listDirectory dir

getParentDir = reverse . tail . dropWhile (/= '/') .  reverse

resetCurrZipper s = (case focus s of
  Catalog -> s {firstCatalogs = Nothing, currActions = Nothing}
  Main.Action -> s {currActions = Nothing}
  SecondCatalog -> s {secondCatalogs = Nothing}

                    )
  {searchText = ""}

moveFocusDown s = case (maybe dummyIOAction toIOAction $ currActions s , focus s) of
  (_, Catalog) -> s {focus = Main.Action}
  (OneParam _, Main.Action) -> s {focus = Catalog, searchText = ""}
  (TwoParam _, Main.Action) -> s {focus = SecondCatalog, searchText = ""}
  (_, SecondCatalog) -> s {focus = Catalog, searchText = ""}
  where
    dummyIOAction :: IOAction
    dummyIOAction = OneParam (const $ return ())

    toIOAction :: LZ.ListZipper Action -> IOAction
    toIOAction = ioAction . LZ.focus

applySearchFilter s searchText'= ( -- looks like lisp lol
    case focus s of
      Catalog -> s {firstCatalogs = catalogs' firstCatalogs, currActions = newActions}
      Main.Action -> s {currActions = currActions'}
      SecondCatalog -> s {secondCatalogs = catalogs' secondCatalogs}) {searchText = searchText'}
  where
    -- here because we'll to check if it's changed later on the actions list
    catalogs' lens = case lens s of
      Nothing -> LZ.fromList . searchableMatches searchText' $ catalog s
      Just toFilter -> LZ.filter (fuzzyMatches searchText' . searchString) toFilter

    -- derived soley from the current catalog
    newActions = LZ.fromList . getActions . LZ.focus =<< firstCatalogs s

    currActions' = case currActions s of
      Nothing -> newActions
      Just toFilter -> LZ.filter (fuzzyMatches searchText' . searchString) toFilter

mapOverFocus :: (forall a. Searchable a => LZ.ListZipper a -> LZ.ListZipper a) -> AppState -> AppState
mapOverFocus f s = case focus s of
  Main.Action -> s {currActions = f <$> currActions s}
  Catalog -> s {firstCatalogs = f <$> firstCatalogs s}
  SecondCatalog -> s {secondCatalogs = f <$> secondCatalogs s}

selectedZipperLeft :: AppState  -> AppState
selectedZipperLeft s = mapOverFocus LZ.moveLeft s

selectedZipperRight :: AppState -> AppState
selectedZipperRight s = mapOverFocus LZ.moveRight s

replaceNothingWith :: Maybe (LZ.ListZipper Cataloged) -> Maybe (LZ.ListZipper Action) -> AppState -> AppState
replaceNothingWith catalogZipper actionZipper s = case focus s of
  Catalog -> s {firstCatalogs = replaceNothingMaybe (firstCatalogs s) catalogZipper}
  Main.Action -> s {currActions = replaceNothingMaybe (currActions s) actionZipper}
  where
    replaceNothingMaybe :: Maybe a -> Maybe a -> Maybe a
    replaceNothingMaybe (Just a) _ = Just a
    replaceNothingMaybe Nothing a = a

filterHiddenFiles :: [FilePath] -> [FilePath]
filterHiddenFiles = filter (not . L.isInfixOf "/.")

main :: IO ()
main = do
  void $ Gtk.init Nothing
  -- Set up screen and CSS provider
  screen <- maybe (fail "No screen?!") return =<< Gdk.screenGetDefault
  p      <- Gtk.cssProviderNew
  styles <- BS.readFile "src/style.css"
  Gtk.cssProviderLoadFromData p styles
  Gtk.styleContextAddProviderForScreen
    screen
    p
    (fromIntegral Gtk.STYLE_PROVIDER_PRIORITY_USER)

  catalog' <- getCatalog
  -- Start main loop
  void . async $ do
    void $ runLoop $ app catalog'
    Gtk.mainQuit
  Gtk.main
    where
  app catalog' = App {
              view         = view'
            , update       = update'
            , inputs       = []
            , initialState = initialAppState catalog'
            }

handleKeyPress ::  EK.EventKey -> Window -> IO (Bool, Event)
handleKeyPress key window = do
  keyPressed <- EK.getEventKeyKeyval key
  return (True , case fromIntegral keyPressed of
             65288 -> Delete
             65289 -> Tab
             65293 -> Enter
             65362 -> Up
             65364 -> Down
             65361 -> Main.Left
             65363 -> Main.Right
             65511 -> Closed
             char -> KeyPressed . C.chr $ char)

initialAppState catalog' = AppState {
  catalog = catalog',
  searchText = "",
  focus = Catalog,
  firstCatalogs = Nothing,
  currActions = Nothing,
  secondCatalogs = Nothing
}

searchCatalog :: AppState -> Maybe Cataloged
searchCatalog s = LZ.focus <$> firstCatalogs s

searchAction :: AppState -> Maybe Action
searchAction s = LZ.focus <$> currActions s

searchableMatches :: Searchable s => T.Text -> [s] -> [s]
searchableMatches s = filter (fuzzyMatches s . searchString)

fuzzyMatches :: T.Text -> T.Text -> Bool
fuzzyMatches "" _ = True
fuzzyMatches _ "" = False
fuzzyMatches s s'
  | T.head s == T.head s' = fuzzyMatches (T.tail s) (T.tail s')
  | otherwise = fuzzyMatches s (T.tail s')