LYAH last assignment - a simple file system, using Either & WriterT

gistfile1.hs

import Data.List (break)
import Control.Monad
import Control.Monad.Instances
import Control.Monad.Trans
import Control.Monad.Trans.Writer

type Name = String
type Data = String

data FSItem = File Name Data | Folder Name [FSItem] deriving (Show)

-- FSCrumb records name of the corresponding zipper' parent (a folder), 
-- and keeps lists of its prev & next brothers. 
data FSCrumb = FSCrumb Name [FSItem] [FSItem] deriving (Show)

type FSZipper = (FSItem, [FSCrumb])

x -: f = f x

fsZipper :: FSItem -> FSZipper
fsZipper item = (item, [])

fsIsRoot :: FSZipper -> Bool
fsIsRoot (z, []) = True
fsIsRoot _ = False

-- move up to its parent
fsUp :: FSZipper -> Either String FSZipper
fsUp (item, (FSCrumb name ls rs):bs) = Right (Folder name (ls ++ [item] ++ rs), bs)
fsUp _ = Left "Cannot move up when focusing on root object"

-- move to a child according to the name
fsTo :: Name -> FSZipper -> Either String FSZipper
fsTo name (Folder folderName items, bs) =
	if (length xrs == 0)
		then Left $ "Cannot find object \"" ++ name ++ "\""
		else Right (item, (FSCrumb folderName ls rs):bs)
	where
		(ls, xrs) = break (isName name) items
		(item:rs) = xrs
		isName :: Name -> FSItem -> Bool
		isName name (Folder folderName _) = name == folderName
		isName name (File fileName _) = name == fileName

-- get a list of object's brother
fsGetBrotherList :: FSZipper -> [FSItem]
fsGetBrotherList zipper = fsCanGetBrother $ fsUp zipper 
	where
		-- if error occurs while moving up, throw an empty list
		fsCanGetBrother (Left _) = []
		fsCanGetBrother (Right (Folder _ brothers, _)) = brothers 

-- get name of a FSItem
fsGetName :: FSItem -> Name
fsGetName (Folder name _) = name
fsGetName (File name _) = name

-- rename the focusing obejct
fsRename :: Name -> FSZipper -> Either String FSZipper
fsRename newName zipper = 
	-- restriction: there must be no name confliction among brothers in same dir.
	if newName `elem` (map fsGetName $ fsGetBrotherList zipper)
		then Left $ "New name \"" ++ newName ++ "\" conflicts with currently existing object"
		else Right $ _fsRename newName zipper
	where
		_fsRename newName (Folder name items, bs) = (Folder newName items, bs)
		_fsRename newName (File name dat, bs) = (File name dat, bs)

-- append FSItem into a Folder
fsNewfile :: FSItem -> FSZipper -> Either String FSZipper
fsNewfile _ (File _ _, _) = Left "Adding new obejct into files is forbidden"
fsNewfile item zipper =
	if (fsGetName item) `elem` (map fsGetName $ fsGetBrotherList zipper)
		then Left $ "New object name \"" ++ (fsGetName item) ++ "\" conflicts with currently existing object"
		else Right $ _fsNewfile item zipper
	where
		_fsNewfile item (Folder folderName items, bs) = (Folder folderName (item:items), bs)

-- remove the focusing object and go up
fsRemove :: FSZipper -> Either String FSZipper
fsRemove zipper =
	if fsIsRoot zipper
		then Left "Cannot remove root object"
		else Right $ fsIgnoreAndUp zipper
	where
		fsIgnoreAndUp (item, (FSCrumb name ls rs):bs) = (Folder name (ls ++ rs), bs)

-- now here is a new challenge: 
-- transform things into writer 
-- so that file system supports keeping logs

-- all functions that end with "W" mean the same functions but in ZipperWriter monad version.
type ZipperWriter = WriterT [String] (Either String)

fsUpW :: FSZipper -> ZipperWriter FSZipper
fsUpW (item, bs) = do
	tell ["Go up, leave \"" ++ (fsGetName item) ++ "\"" ]
	t <- lift $ fsUp (item, bs)
	return t

-- provide a way of reaching root in one command
fsToRootW :: FSZipper -> ZipperWriter FSZipper
fsToRootW (item, b:bs) = do
	t <- fsUpW (item, b:bs)
	fsToRootW t
fsToRootW (item, []) = do
	tell ["Reach root \"" ++ (fsGetName item) ++ "\"" ]
	return (item, [])

fsToW :: Name -> FSZipper -> ZipperWriter FSZipper
fsToW n z = do
	tell ["Go to object \"" ++ n ++ "\""  ]
	t <- lift $ fsTo n z
	return t

fsRenameW :: Name -> FSZipper -> ZipperWriter FSZipper
fsRenameW n (item, bs) = do
	tell ["Rename object \"" ++ (fsGetName item) ++ "\" to \"" ++ n ++ "\""]
	t <- lift $ fsRename n (item, bs)
	return t

fsNewfileW :: FSItem -> FSZipper -> ZipperWriter FSZipper
fsNewfileW i z = do
	tell ["Insert object \"" ++ (fsGetName i) ++ "\""]
	t <- lift $ fsNewfile i z
	return t

fsRemoveW :: FSZipper -> ZipperWriter FSZipper
fsRemoveW (item, bs) = do
	tell ["Remove object \"" ++ (fsGetName item) ++ "\""]
	t <- lift $ fsRemove (item, bs)
	return t

-- make the root of our file system, here I simply clear breadcrumbs and print log
fsMakeW :: FSZipper -> ZipperWriter FSZipper
fsMakeW (root, _) = do
	tell ["Make new file system, the root is \"" ++ (fsGetName root) ++ "\""]
	return (root, [])

-- generate a human-readable version print of the given FSItem
fsShow :: Int -> FSItem -> [String]
fsShow lvl (File name _) = [ (replicate (4*lvl) ' ') ++ ('|':name) ]
fsShow lvl (Folder name items) =
	[(replicate (4*lvl) ' ') ++ ('+':name)] ++ concat (map (fsShow (lvl+1)) items)

fsShowW :: FSZipper -> ZipperWriter FSZipper
fsShowW z = do
	tell ["Print file system structure:", "-- BEGIN"]
	let (item, _) = z
	tell $ fsShow 0 item
	tell ["-- END"]
	return z

-- buildMyDisk will make this structure (myDisk) 
-- and do some modification on this structure.

-- myDisk :: FSItem
-- myDisk = 
-- 	Folder "root"
-- 	[
-- 		Folder "dir1"
-- 		[
-- 			File "FileA" "aaaa",
-- 			File "FileB" "bbbb",
-- 			Folder "Empty" []
-- 		],
-- 		Folder "dir2"
-- 		[
-- 			Folder "subdir1"
-- 			[
-- 				Folder "subdir2"
-- 				[
-- 					File "FileA" "asdf",
-- 					File "FileB" "hjkl"
-- 				]
-- 			]
-- 		],
-- 		File "file.txt" "Test"
-- 	]

-- the initial object of our file system
rawDisk :: FSItem
rawDisk = Folder "root" []

buildMyDisk :: FSZipper -> ZipperWriter FSZipper
buildMyDisk = foldl (\acc i-> i <=< acc) return operationList 
	where
		operationList =
			[
				fsMakeW,
				fsShowW,
				fsNewfileW $ File "file.txt" "Test",
				fsNewfileW $ Folder "dir2" [],
				fsToW "dir2",
				fsNewfileW $ Folder "subdir1" [],
				fsToW "subdir1",
				fsNewfileW $ Folder "subdir2" [],
				fsToW "subdir2",
				fsNewfileW $ File "FileB" "hjkl",
				fsNewfileW $ File "FileA" "asdf",
				fsToRootW,
				fsNewfileW $ Folder "dir1" [],
				fsToW "dir1",
				fsNewfileW $ Folder "Empty" [],
				fsNewfileW $ File "FileB" "bbbb",
				fsNewfileW $ File "FileA" "aaaa",
				fsUpW,
				fsShowW,
				fsToRootW,
				fsRenameW "ROOT",
				fsToW "dir1",
				fsRemoveW,
				fsShowW
			]

printTestCase = do
	let (Right (_,res)) = runWriterT $ buildMyDisk $ fsZipper rawDisk
	mapM_ putStrLn res

main = printTestCase