Basic Directory / 'Text entry' create / delete / traversal (bash inspired) in Haskell

Question

I'm new to Haskell and functional programming and I did for training purpose a basic program where you can:

• create a directory (consisting of a name and an array of sub-directories)
• create an entry (consisting for a title and a content)
• remove and entry or a directory
• view an entry
• do a directory listing

The available commands are:

• ls
• cd dir or cd .. (to go to parent)
• mkdir dirname
• view entry
• exit
• help

Notes:

• There is not dependencies on Hackage (out of the box "The Haskell Platform" is enough).
• I corrected the source for hlint and now there is "no suggestions".

`

import Data.Maybe
import Data.List (sortBy,elemIndex,intercalate)
import Data.Function (on)
import System.IO (stdout,hFlush)
import System.Directory (doesFileExist)
-- -- -- -- -- -- -- -- -- -- -- --
-- DATA and their functions
-- -- -- -- -- -- -- -- -- -- -- --
-- Ex: - Directory { name = "dir1", directories = Directory { name = "dir2" } }
-- - path for dir2 will be ["dir2", "dir1"]
-- - getCurrentDirectory function get 'root Directory' + 'path' and return the directory at 'path'
data Entry = Entry { title :: String
 ,content :: String } deriving (Show, Read)
data Directory = Directory { name :: String,
 directories :: [Directory],
 entries :: [Entry] } deriving (Show, Read)
-- Add an entry into the directory tree.
addEntry :: Directory -> [String] -> Entry -> Directory
addEntry dir [] newEntry = addDirectoryEntry dir newEntry
addEntry dir path newEntry = replaceDirectoryInPath dir (tail path) $ addDirectoryEntry currentDir newEntry
 where currentDir = getCurrentDirectory dir path
-- Add a directory into the directory tree.
addDirectory :: Directory -> [String] -> Directory -> Directory
addDirectory dir [] newDir = addDirectoryDirectory dir newDir
addDirectory dir path newDir = replaceDirectoryInPath dir (tail path) $ addDirectoryDirectory currentDir newDir
 where currentDir = getCurrentDirectory dir path
-- Remove an entry from the directory tree.
removeEntry :: Directory -> [String] -> Entry -> Directory
removeEntry dir [] e = removeDirectoryEntry dir e
removeEntry dir path e = replaceDirectoryInPath dir (tail path) $ removeDirectoryEntry currentDir e
 where currentDir = getCurrentDirectory dir path
-- Remove a directory from the directory tree.
removeDirectory :: Directory -> [String] -> Directory -> Directory
removeDirectory dir [] d = removeDirectoryDirectory dir d
removeDirectory dir path d = replaceDirectoryInPath dir (tail path) $ removeDirectoryDirectory currentDir d
 where currentDir = getCurrentDirectory dir path
-- Add an entry in a directory
addDirectoryEntry :: Directory -> Entry -> Directory
addDirectoryEntry dir e = Directory {
 name = name dir,
 directories = directories dir,
 entries = sortBy (compare `on` title) (e : entries dir)
 }
-- Add a directory in a directory
addDirectoryDirectory :: Directory -> Directory -> Directory
addDirectoryDirectory dir d = Directory {
 name = name dir,
 directories = sortBy (compare `on` name) (d : directories dir),
 entries = entries dir
 }
-- Remove an entry from a directory
removeDirectoryEntry :: Directory -> Entry -> Directory
removeDirectoryEntry dir e = Directory {
 name = name dir,
 directories = directories dir,
 entries = filter ((title e /= ) . title) (entries dir)
 }
-- Remove a directory from a directory
removeDirectoryDirectory :: Directory -> Directory -> Directory
removeDirectoryDirectory dir d = Directory {
 name = name dir,
 directories = filter ((name d /= ) . name) (directories dir),
 entries = entries dir
 }
-- Replace a directory in the specified path
-- Input: dir "xxx/yyy/zzz" "aaa"
-- Does: dir' = xxx/yyy/aaa
-- Returns: dir'
replaceDirectoryInPath :: Directory -> [String] -> Directory -> Directory
replaceDirectoryInPath dir [] newDir = addDirectoryDirectory (removeDirectoryDirectory dir newDir) newDir
replaceDirectoryInPath dir path newDir =
 replaceDirectoryInPath dir (tail path) $ addDirectoryDirectory (removeDirectoryDirectory currentDir newDir) newDir
 where currentDir = getCurrentDirectory dir path
-- Return the last directory specified by path
-- dir "xxx/yyy/zzz" returns zzz
getCurrentDirectory :: Directory -> [String] -> Directory
getCurrentDirectory dir [] = dir
getCurrentDirectory dir path = getCurrentDirectory (fromJust (getDirectory dir (last path))) (init path)
-- Return entry from dir by name
getEntry :: Directory -> String -> Maybe Entry
getEntry dir s = if length e > 0 then Just $ head e else Nothing
 where e = filter ((== s) . title) (entries dir)
-- Return directory from dir by name
getDirectory :: Directory -> String -> Maybe Directory
getDirectory dir s = if length d > 0 then Just $ head d else Nothing
 where d = filter ((== s) . name) (directories dir)
-- -- -- -- -- -- -- -- -- -- -- --
-- The application
-- -- -- -- -- -- -- -- -- -- -- --
main :: IO ()
main = do
 let filename = "EntryBook.dat"
 dir <- loadData filename
 ls dir
 newDir <- prompt dir []
 saveData filename newDir
 return ()
-- Prompt
prompt :: Directory -> [String] -> IO Directory
prompt dir path = do 
 putStr "/"
 putStr $ intercalate "/" (reverse path)
 putStr "$ "
 hFlush stdout
 userInput <- getLine
 case strip userInput of
 "exit" -> return dir
 "" -> prompt dir path
 xd -> do
 (msg, newDir, newPath) <- dispatch (strip userInput) dir path
 if msg == "" 
 then do
 ls $ getCurrentDirectory newDir newPath
 prompt newDir newPath
 else do
 putStrLn msg
 prompt newDir newPath
 where currentDir = getCurrentDirectory dir path
-- Dispatch user commands
dispatch :: String -> Directory -> [String] -> IO (String, Directory, [String])
dispatch "ls" dir path = do
 itemsNr <- ls currentDir
 return (show itemsNr ++ " element(s) found", dir, path)
 where currentDir = getCurrentDirectory dir path
dispatch ('c':'d':' ':s) (dir) (path) = do
 let (msg, newPath) = cd dir path s
 return (msg, dir, newPath)
dispatch ('v':'i':'e':'w':' ':xs) (dir) (path) = do
 let e = getEntry currentDir xs
 if isJust e
 then do
 displayEntry $ fromJust e
 return ("", dir, path)
 else
 return (xs ++ ": no such entry", dir, path)
 where currentDir = getCurrentDirectory dir path
dispatch "new" dir path = do
 e <- newEntry
 let newDir = addEntry dir path e
 return ("", newDir, path)
dispatch ('m':'k':'d':'i':'r':' ':xs) (dir) (path) = do
 let newDir = addDirectory dir path $ Directory xs [] []
 return ("", newDir, path)
dispatch ('r':'m':' ':xs) (dir) (path) = return $ rm dir path xs
dispatch "help" dir path = do
 help
 return ("", dir, path)
dispatch xs dir path = return (xs ++ ": command not found\nType 'help' for all available commands.", dir, path)
-- Directory listing
ls :: Directory -> IO Int
ls dir = do
 putStrLn $ "Directory name: " ++ name dir
 putStrLn "Directory listing:"
 mapM_ (\a -> putStrLn ("d| " ++ name a)) (directories dir)
 mapM_ (\a -> putStrLn ("e| " ++ title a)) (entries dir)
 return $ length (directories dir) + length (entries dir)
-- -- -- -- -- -- -- -- -- -- -- --
-- The functions
-- -- -- -- -- -- -- -- -- -- -- --
-- Change directory
cd :: Directory -> [String] -> String -> (String, [String])
cd dir path dest =
 case dest of
 "/" -> ("", [last path])
 "" -> ("", path)
 "." -> ("", path)
 ".." -> if length path > 0 then ("", tail path) else ("", path)
 xs -> do
 let d = getDirectory (getCurrentDirectory dir path) xs
 if isJust d
 then
 ("", name (fromJust d) : path)
 else
 (xs ++ ": no such directory", path)
-- Remove an entry or a directory
rm :: Directory -> [String] -> String -> (String, Directory, [String])
rm dir path xs = do
 let d = getDirectory currentDir xs
 if isJust d
 then do
 let newDir = removeDirectory dir path $ fromJust d
 ("", newDir, path)
 else do
 let e = getEntry currentDir xs
 if isJust e
 then do
 let newDir = removeEntry dir path $ fromJust e
 ("", newDir, path)
 else
 (xs ++ ": no such directory or entry", dir, path)
 where currentDir = getCurrentDirectory dir path
-- Print Help
help :: IO ()
help = do
 putStrLn "Available commands:"
 putStrLn "- exit: exit the application"
 putStrLn "- ls: list directory contents"
 putStrLn "- cd [dir]: change the current directory to dir"
 putStrLn "- mkdir [dir]: create a new directory [dir]"
 putStrLn "- view [entry]: display the content of entry"
 putStrLn "- new: open the entry creation screen"
 putStrLn "- help: display this help"
-- Create entry from user input
newEntry :: IO Entry
newEntry = do
 putStrLn "Entry title: "
 title <- getLine
 putStrLn "Entry content (type // to end): "
 content <- getMultilineText
 return $ Entry title content
-- Get multiline text from user input
getMultilineText :: IO String
getMultilineText = do
 text <- getLine
 if text == "//"
 then return ""
 else do
 newText <- getMultilineText
 return $ text ++ newText
-- Display an entry
displayEntry :: Entry -> IO ()
displayEntry e = do
 putStrLn ""
 putStrLn $ "Title: " ++ title e
 putStrLn "Content: "
 putStrLn $ content e
 exitOnInput <- getLine
 return ()
-- Save data to disk
saveData :: String -> Directory -> IO ()
saveData filename dir = do
 writeFile filename $ show dir
 return ()
-- Load data from disk
loadData :: String -> IO Directory
loadData filename = do
 fileExist <- doesFileExist filename
 if fileExist
 then do
 contents <- readFile filename
 let dir = read contents :: Directory
 return dir
 else return $ Directory "root" [] []
-- -- -- -- -- -- -- -- -- -- -- --
-- Helper function
-- -- -- -- -- -- -- -- -- -- -- --
strip :: String -> String
strip = lstrip . rstrip
lstrip :: String -> String
lstrip = dropWhile (`elem` " \t")
rstrip :: String -> String
rstrip = reverse . lstrip . reverse
split :: Char -> String -> [String]
split delim [] = [""]
split delim (c:cs)
 | c == delim = "" : rest
 | otherwise = (c : head rest) : tail rest
 where
 rest = split delim cs

I would be pleased with any advises concerning the data structure, the code style or anything else. Thank you.

Answer 1

Here are a few things that could be done in your code.

{-# LANGUAGE TemplateHaskell, ViewPatterns #-}

I use template haskell to derive data lenses, which make your directory access a little more succinct. I also use ViewPatterns so that the dispatch on string prefixes are easier.

import Data.Maybe
import Data.List (sortBy,groupBy,elemIndex,intercalate,stripPrefix)
import Data.Function (on)
import System.IO (stdout,hFlush)
import System.Directory (doesFileExist)
import Control.Monad
import Control.Applicative
import Data.Lens.Template (makeLenses)
import Data.Lens.Lazy

Notice the underscores in member names, these are converted to their lense equivalents by makeLenses

data Entry = Entry { _title :: String, _content :: String }
 deriving (Show, Read)
data Directory = Directory 
 { _name :: String, _directories :: [Directory], _entries :: [Entry] }
 deriving (Show, Read)
$( makeLenses [''Directory, ''Entry])

These few functions are tight. There is nothing more to be done with them I think. However, it should be noted that Entry and Directory have complementary functions everywhere. Perhaps it is profitable to abstract the common skeleton.

-- Add an entry into the directory tree.
addEntry :: Directory -> [String] -> Entry -> Directory
addEntry dir [] newEntry = addDirectoryEntry dir newEntry
addEntry dir path newEntry = replaceDirectoryInPath dir (tail path) 
 $ addDirectoryEntry currentDir newEntry
 where currentDir = getCurrentDirectory dir path
-- Add a directory into the directory tree.
addDirectory :: Directory -> [String] -> Directory -> Directory
addDirectory dir [] newDir = addDirectoryDirectory dir newDir
addDirectory dir path newDir = replaceDirectoryInPath dir (tail path) 
 $ addDirectoryDirectory currentDir newDir
 where currentDir = getCurrentDirectory dir path
-- Remove an entry from the directory tree.
removeEntry :: Directory -> [String] -> Entry -> Directory
removeEntry dir [] e = removeDirectoryEntry dir e
removeEntry dir path e = replaceDirectoryInPath dir (tail path) 
 $ removeDirectoryEntry currentDir e
 where currentDir = getCurrentDirectory dir path
-- Remove a directory from the directory tree.
removeDirectory :: Directory -> [String] -> Directory -> Directory
removeDirectory dir [] d = removeDirectoryDirectory dir d
removeDirectory dir path d = replaceDirectoryInPath dir (tail path) 
 $ removeDirectoryDirectory currentDir d
 where currentDir = getCurrentDirectory dir path

We start getting use out of the lenses here. Compare it to your code.

-- Add an entry in a directory
addDirectoryEntry :: Directory -> Entry -> Directory
addDirectoryEntry dir e = entries ^%= (sortBy (compare `on` _title)) . (e :) $ dir
-- Add a directory in a directory
addDirectoryDirectory :: Directory -> Directory -> Directory
addDirectoryDirectory dir d = directories ^%= (sortBy (compare `on` _name)) . (d :) $ dir
-- Remove an entry from a directory
removeDirectoryEntry :: Directory -> Entry -> Directory
removeDirectoryEntry dir e = entries ^%= (filter ((_title e /=) . _title)) $ dir
-- Remove a directory from a directory
removeDirectoryDirectory :: Directory -> Directory -> Directory
removeDirectoryDirectory dir d = directories ^%= (filter ((_name d /=) . _name)) $ dir
-- Replace a directory in the specified path
-- Input: dir "xxx/yyy/zzz" "aaa"
-- Does: dir' = xxx/yyy/aaa
-- Returns: dir'
replaceDirectoryInPath :: Directory -> [String] -> Directory -> Directory
replaceDirectoryInPath dir [] newDir = addDirectoryDirectory 
 (removeDirectoryDirectory dir newDir) newDir
replaceDirectoryInPath dir path newDir =
 replaceDirectoryInPath dir (tail path) 
 $ addDirectoryDirectory (removeDirectoryDirectory currentDir newDir) newDir
 where currentDir = getCurrentDirectory dir path
-- Return the last directory specified by path
-- dir "xxx/yyy/zzz" returns zzz
getCurrentDirectory :: Directory -> [String] -> Directory
getCurrentDirectory dir [] = dir
getCurrentDirectory dir path = getCurrentDirectory 
 $ fromJust (getDirectory dir (last path))) (init path)
-- Return entry from dir by name
getEntry :: Directory -> String -> Maybe Entry
getEntry dir s = if length e > 0 then Just $ head e else Nothing
 where e = filter ((== s) . _title) (_entries dir)
-- Return directory from dir by name
getDirectory :: Directory -> String -> Maybe Directory
getDirectory dir s = if length d > 0 then Just $ head d else Nothing
 where d = filter ((== s) . _name) (_directories dir)
-- -- -- -- -- -- -- -- -- -- -- --
-- The application
-- -- -- -- -- -- -- -- -- -- -- --
filename = "EntryBook.dat"
main :: IO ()
main = loadData filename >>= (\dir -> ls dir >> prompt dir []) >>= saveData filename
-- Prompt
prompt :: Directory -> [String] -> IO Directory
prompt dir path = do 
 putStr $ concat ["/",intercalate "/" (reverse path), "$ "]
 hFlush stdout
 userInput <- getLine
 case strip userInput of
 "exit" -> return dir
 "" -> prompt dir path
 xd -> domore dir path xd 
 where currentDir = getCurrentDirectory dir path
 domore dir path xd = do
 (msg, newDir, newPath) <- dispatch xd dir path
 if msg == "" then
 (ls $ getCurrentDirectory newDir newPath) >> return ()
 else putStrLn msg
 prompt newDir newPath

With ViewPatterns, we can match on string prefixes

-- Dispatch user commands
dispatch :: String -> Directory -> [String] -> IO (String, Directory, [String])
dispatch "ls" dir path = do
 itemsNr <- ls currentDir
 return (show itemsNr ++ " element(s) found", dir, path)
 where currentDir = getCurrentDirectory dir path
dispatch (stripPrefix "cd " -> Just xs) dir path = return (msg, dir, newPath)
 where (msg, newPath) = cd dir path xs
dispatch (stripPrefix "view " -> Just xs) dir path = case getEntry currentDir xs of
 Just x -> displayEntry x >> return ("", dir, path)
 _ -> return (xs ++ ": no such entry", dir, path)
 where currentDir = getCurrentDirectory dir path
dispatch "new" dir path = newEntry >>= \e -> return ("", addEntry dir path e, path)
dispatch (stripPrefix "mkdir " -> Just xs) dir path = return ("", newDir, path)
 where newDir = addDirectory dir path $ Directory xs [] []
dispatch (stripPrefix "rm " -> Just xs) dir path = return $ rm dir path xs
dispatch "help" dir path = help >> return ("", dir, path)
dispatch xs dir path = return (xs ++ 
 ": command not found\nType 'help' for all available commands.", dir, path)

Notice the reduction in code for the dispatched commands.

-- Directory listing
ls :: Directory -> IO Int
ls dir = do
 putStrLn $ "Directory name: " ++ (_name dir)
 putStrLn "Directory listing:"
 mapM_ (putStrLn . ("d| " ++) . _name) $ _directories dir
 mapM_ (putStrLn . ("e| " ++) . _title) $ _entries dir
 return $ length (_directories dir) + length (_entries dir)
-- -- -- -- -- -- -- -- -- -- -- --
-- The functions
-- -- -- -- -- -- -- -- -- -- -- --
-- Change directory
cd :: Directory -> [String] -> String -> (String, [String])
cd dir path dest =
 case dest of
 "/" -> ("", [last path])
 "" -> ("", path)
 "." -> ("", path)
 ".." -> ("", if null path then path else tail path)
 xs -> case getDirectory (getCurrentDirectory dir path) xs of
 Just x -> ("", _name x : path)
 Nothing -> (xs ++ ": no such directory", path)
-- Remove an entry or a directory
rm :: Directory -> [String] -> String -> (String, Directory, [String])
rm dir path xs = fromMaybe (xs ++ ": no such directory or entry", dir, path)
 $ myfn (getDirectory, removeDirectory) `mplus` myfn (getEntry, removeEntry)
 where currentDir = getCurrentDirectory dir path
 myfn (fna, fnb) = fna currentDir xs >>= \x -> return ("", fnb dir path x, path)

We can profitably use unlines to simulate heredocs in haskell.

-- Print Help
help :: IO ()
help = putStrLn $ unlines [
 "Available commands:",
 "- exit: exit the application",
 "- ls: list directory contents",
 "- cd [dir]: change the current directory to dir",
 "- mkdir [dir]: create a new directory [dir]",
 "- view [entry]: display the content of entry",
 "- new: open the entry creation screen",
 "- help: display this help"]
-- Create entry from user input
newEntry :: IO Entry
newEntry = getPromptLine "Entry title: " <*
 putStrLn "Entry content (type // to end): " >>= (<$> getMultilineText) . Entry
getPromptLine :: String -> IO String
getPromptLine prompt = putStrLn prompt >> getLine 
-- Get multiline text from user input
getMultilineText :: IO String
getMultilineText = getLine >>= checkEnd
 where checkEnd "//" = return []
 checkEnd t = (++) t <$> getMultilineText
-- Display an entry
displayEntry :: Entry -> IO ()
displayEntry e = putStrLn (unlines ["", "Title: " ++ (_title e),
 "Content: ", _content e]) >> getLine >> return ()
-- Save data to disk
saveData :: String -> Directory -> IO ()
saveData filename dir = writeFile filename $ show dir
-- Load data from disk
loadData :: String -> IO Directory
loadData filename = check =<< doesFileExist filename
 where check True = read <$> readFile filename
 check False = return $ Directory "root" [] []
-- -- -- -- -- -- -- -- -- -- -- --
-- Helper function
-- -- -- -- -- -- -- -- -- -- -- --
strip :: String -> String
strip = lstrip . rstrip
lstrip :: String -> String
lstrip = dropWhile (`elem` " \t")
rstrip :: String -> String
rstrip = reverse . lstrip . reverse