~jackwines/fast-bronze

c60e8501a4a4ce47c7eb800042e77ec0cf9e3448 — Jack Wines a month ago 93636f0 master
Last commit prior to monomer switch
4 files changed, 73 insertions(+), 162 deletions(-)

M cabal.project
M fast-bronze.cabal
M src/Catalog.hs
M src/Main.hs
M cabal.project => cabal.project +3 -2
@@ 1,5 1,6 @@
packages: *.cabal

-- executable-static:   true

-- jobs: $ncpus
allow-newer: all
allow-newer: haskell-gi, gi-gtk-declarative-app-simple
allow-older: haskell-gi, gi-gtk-declarative-app-simple

M fast-bronze.cabal => fast-bronze.cabal +16 -16
@@ 1,4 1,4 @@
cabal-version:       2.0
cabal-version:       3.6
-- Initial package description 'fast-bronze.cabal' generated by 'cabal
-- init'.  For further documentation, see
-- http://haskell.org/cabal/users-guide/


@@ 32,7 32,7 @@ executable fast-bronze
                       FlexibleContexts,
                       FlexibleInstances,
                       MultiParamTypeClasses,
                       OverloadedLabels
                       OverloadedLabels,
                       TypeFamilies,
                       UndecidableInstances,
                       RecursiveDo,


@@ 43,20 43,20 @@ executable fast-bronze
                       ListZipper
  -- other-extensions:
  build-depends:
                       async                         >= 2.2.2 && < 2.3,
                       base                          >= 4.0,
                       bytestring                    >= 0.10.10 && < 0.11,
                       text                          >= 1.2.3 && < 1.3,
                       directory                     >= 1.3.6 && < 1.4,
                       unix                          >= 2.7.2 && < 2.8,
                       gi-gdk                        >= 3.0.22 && < 3.1,
                       haskell-gi-base               >= 0.23.0,
                       vector                        >= 0.12.1 && < 0.13,
                       gi-gtk                        >= 3.0.33 && < 3.1,
                       gi-gtk-declarative            >= 0.6.3 && < 0.7,
                       gi-gtk-declarative-app-simple >= 0.6.3 && < 0.7,
                       pipes                         >= 4.3.14 && < 4.4,
                       pipes-extras                  >= 1.0.15 && < 1.1
                       async
                       ,base
                       ,bytestring
                       ,text
                       ,directory
                       ,unix
                       ,gi-gdk
                       ,haskell-gi-base
                       ,vector
                       ,gi-gtk
                       ,gi-gtk-declarative
                       ,gi-gtk-declarative-app-simple
                       ,pipes
                       ,pipes-extras
  default-language:    Haskell2010
  hs-source-dirs:      src
  ghc-options:         -threaded

M src/Catalog.hs => src/Catalog.hs +31 -24
@@ 7,7 7,7 @@ import qualified System.Info as In
data SearchDir = SearchDir {
  dirDepth ::Int,
  searchDir :: FilePath
                 } deriving (Show)
                 } deriving (Show, Eq, Ord)
data Action = Action {
  actionSearchString :: T.Text,
  ioAction :: IOAction


@@ 18,9 18,9 @@ data IOAction = OneParam (Cataloged -> IO ()) | TwoParam (Cataloged -> Cataloged
data Cataloged = Cataloged {
  inputType :: InputType,
  dirPath ::  T.Text
  } deriving (Show)
  } deriving (Show, Eq, Ord)

data InputType = Folder | Text | Other deriving (Show, Eq)
data InputType = Folder | File deriving (Show, Eq, Ord)

instance Searchable Action where
  searchString = actionSearchString


@@ 47,29 47,36 @@ getCatalog = do

-- recursively crawl a directory to the desired depth
searchCatalogItem :: SearchDir -> IO [Cataloged]
searchCatalogItem (SearchDir depth dir) = do
  isDir <- P.isDirectory <$> P.getFileStatus dir
  dir' <- D.makeAbsolute dir
  let currCatalog = dirToCatalog dir' isDir
  case (depth, isDir) of
    (0, _) -> return [currCatalog]
    (_, False) -> return [currCatalog]
    (_, True) -> do
      childPaths <- D.listDirectory dir
      childCatalogs :: [Cataloged] <- mconcat <$> mapM recSearchCatalog childPaths
      return $ currCatalog : childCatalogs
searchCatalogItem (SearchDir depth path) = do
  asCatalogMaybe <- dirToCatalog path
  case (depth, asCatalogMaybe) of
    (_, Nothing) -> print path >> return []
    (0, Just asCatalog) -> return [asCatalog]
    (_, Just asCatalog) -> case inputType asCatalog of
      File -> return [asCatalog]
      Folder -> do
        childPaths <- D.listDirectory path
        childCatalogs <- mconcat <$> mapM recSearchCatalog childPaths
        return $ asCatalog : childCatalogs
  where
    recSearchCatalog :: FilePath -> IO [Cataloged]
    recSearchCatalog x = searchCatalogItem . SearchDir (pred depth) $ (dir ++ "/" ++ x)



dirToCatalog :: FilePath -> Bool -> Cataloged
dirToCatalog dir isDir =
  Cataloged {
    inputType = if isDir then Folder else Other,
    dirPath = T.pack dir
         }
    recSearchCatalog childName = searchCatalogItem . SearchDir (pred depth) $ (path ++ "/" ++ childName)

dirToCatalog :: FilePath -> IO (Maybe Cataloged)
dirToCatalog path = do
  fileExists <- P.fileExist path
  inputTypeMaybe <- if fileExists then toInputType <$> P.getFileStatus path else return Nothing
  return $
    (\inputType -> Cataloged {
      inputType = inputType,
      dirPath = T.pack path
    }) <$> inputTypeMaybe

toInputType :: P.FileStatus -> Maybe InputType
toInputType fileType
  | P.isDirectory fileType = Just Folder
  | P.isRegularFile fileType = Just Folder
  | otherwise = Nothing

-- we only match the first one because the action is always the second thing
-- that's selected, regardless of how many inputs the action takes

M src/Main.hs => src/Main.hs +23 -120
@@ 35,7 35,10 @@ 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))
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]


@@ 56,120 59,24 @@ view' :: AppState -> AppView Window Event
view' s =
  bin
      Window
      [ #title := (maybe "fast-bronze" dirPath $ searchCatalog s)
      [ #title := maybe "fast-bronze" dirPath (searchCatalog s)
      , on #deleteEvent (const (True, Closed))
      , onM #keyPressEvent handleKeyPress
      , #widthRequest := 600
      , #heightRequest := if actionRequiresSecondCatalog then 600 else 400
      , #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"]]
        }
      ]
    $ 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


@@ 187,9 94,7 @@ update' s Main.Right = Transition s $
      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
        Just . ReplaceCatalog . tail <$> searchCatalogItem (SearchDir 1 currPath)
    _ -> return Nothing
update' s Main.Left = Transition s $
  case (firstCatalogs s, focus s) of


@@ 197,10 102,7 @@ update' s Main.Left = Transition s $
      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
        Just . ReplaceCatalog . tail <$> searchCatalogItem (SearchDir 1 currPathParent)
    _ -> return Nothing
update' s (ReplaceCatalog c) = Transition (replaceCatalog s c) (return Nothing)
update' s Enter =


@@ 271,10 173,10 @@ mapOverFocus f s = case focus s of
  SecondCatalog -> s {secondCatalogs = f <$> secondCatalogs s}

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

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

replaceNothingWith :: Maybe (LZ.ListZipper Cataloged) -> Maybe (LZ.ListZipper Action) -> AppState -> AppState
replaceNothingWith catalogZipper actionZipper s = case focus s of


@@ 302,6 204,7 @@ main = do
    (fromIntegral Gtk.STYLE_PROVIDER_PRIORITY_USER)

  catalog' <- getCatalog
  print catalog'
  -- Start main loop
  void . async $ do
    void $ runLoop $ app catalog'