50 lines
1.3 KiB
Haskell
50 lines
1.3 KiB
Haskell
module Main where
|
|
|
|
import Control.Monad.State (MonadState(..), StateT(..), evalStateT, lift, modify)
|
|
import Data.List (isPrefixOf, findIndex)
|
|
import System.Environment (getArgs)
|
|
import System.Exit (die)
|
|
import System.IO (BufferMode(..), hSetBuffering, stdin)
|
|
import Zipper (Tree(..), Zipper(..), at, parse, up)
|
|
|
|
data Command = Quit | Up | Open Int
|
|
type Zipping = StateT Zipper IO
|
|
|
|
getLines :: Zipping [String]
|
|
getLines = fmap fst . children . focus <$> get
|
|
|
|
browse :: Zipper -> IO ()
|
|
browse zipper = do
|
|
hSetBuffering stdin NoBuffering
|
|
evalStateT browseMain zipper
|
|
|
|
prompt :: Zipping Command
|
|
prompt = do
|
|
input <- lift $ getLine
|
|
case input of
|
|
"q" -> return Quit
|
|
"quit" -> return Quit
|
|
"\DEL" -> return Up
|
|
"up" -> return Up
|
|
s -> maybe (retry s) (return . Open) =<< firstMatch s
|
|
where
|
|
retry s = lift (putStrLn ("Command '" ++ s ++ "' not understood")) >> prompt
|
|
firstMatch s = findIndex (s `isPrefixOf`) <$> getLines
|
|
|
|
browseMain :: Zipping ()
|
|
browseMain = do
|
|
lift $ putStrLn "---------------------------------"
|
|
lift . mapM_ putStrLn =<< getLines
|
|
command <- prompt
|
|
case command of
|
|
Quit -> return ()
|
|
Up -> modify up >> browseMain
|
|
Open n -> modify (at n) >> browseMain
|
|
|
|
main :: IO ()
|
|
main = do
|
|
args <- getArgs
|
|
case args of
|
|
[filePath] -> readFile filePath >>= browse . parse
|
|
_ -> die "Syntax: lemur FILE_PATH"
|