~jackwines/fast-bronze

ref: c60e8501a4a4ce47c7eb800042e77ec0cf9e3448 fast-bronze/src/Main.hs -rw-r--r-- 9.7 KiB
c60e8501Jack Wines Last commit prior to monomer switch 3 months 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
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
import GI.Gtk.Objects.ListBoxRow
import Data.Vector.Storable.Mutable (grow)
import GI.Gtk.Declarative.Container.Grid (GridChildProperties(height))


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 := 300
      ]
    $
      container Grid [#hexpand := True, #vexpand := True, classes ["unselected"]]
      [
        GridChild {
          properties = defaultGridChildProperties {height = 1, width = 1, topAttach = 0, leftAttach = 0},
          child = widget Label [#hexpand := True, #vexpand := True, #label := "top"]
        },
        GridChild {
          properties = defaultGridChildProperties {height = 1, width = 1, topAttach = 2, leftAttach = 0},
          child = widget Label [#hexpand := True, #vexpand := True, #label := "bottom", classes ["selected"]]
        }
      ]

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
        Just . ReplaceCatalog . tail <$> searchCatalogItem (SearchDir 1 currPath)
    _ -> 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
        Just . ReplaceCatalog . tail <$> searchCatalogItem (SearchDir 1 currPathParent)
    _ -> 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 = mapOverFocus LZ.moveLeft

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

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
  print catalog'
  -- 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')