Haskell - 入出力事例研究: ファイルシステム検索ライブラリ、正規表現、ファイル名マッチング(走査方法の制御、結果をフィルタ)

Real World Haskell
実戦で学ぶ関数型言語プログラミング
(オライリージャパン)
Bryan O'Sullivan (著) John Goerzen (著)
Don Stewart (著)
山下 伸夫 (翻訳) 伊東 勝利 (翻訳)
株式会社タイムインターメディア (翻訳)

開発環境

• OS X Mavericks - Apple(OS)
• BBEdit - Bare Bones Software, Inc., Emacs (Text Editor)
• Haskell (純粋関数型プログラミング言語)
• GHC (The Glasgow Haskell Compiler) (処理系)
• The Haskell Platform (インストール方法、モジュール等)

Real World Haskell―実戦で学ぶ関数型言語プログラミング(Bryan O'Sullivan (著)、 John Goerzen (著)、 Don Stewart (著)、山下 伸夫 (翻訳)、伊東 勝利 (翻訳)、株式会社タイムインターメディア (翻訳)、オライリージャパン)の9章(入出力事例研究: ファイルシステム検索ライブラリ)、9.7(走査方法の制御)の練習問題 4.を解いてみる。

その他参考書籍

• すごいHaskellたのしく学ぼう!(オーム社) Miran Lipovača(著)、田中 英行、村主 崇行(翻訳)
• プログラミングHaskell (オーム社) Graham Hutton(著) 山本 和彦(翻訳)

練習問題 4.

コード(BBEdit, Emacs)

ControlledVisit.hs

{-# OPTIONS -Wall -Werror #-}
module ControlledVisit where

import System.Directory (Permissions, getDirectoryContents, getPermissions,
                         getModificationTime, searchable)
import System.IO (IOMode(..), openFile, hClose, hFileSize)
-- System.Timeは非推奨
import Data.Time.Clock (UTCTime)
import Data.List (isInfixOf)
import System.FilePath ((</>))
import Control.Exception (handle, bracket, SomeException)
import Control.Monad (liftM, forM)

main :: IO ()
main = do
    infos1 <- traverse id "../"
    infos2 <- traverseP id testP "../"
    putStrLn "id--------------------------------------"
    mapM_ putStrLn $ map infoPath infos1
    putStrLn "パス名にtempを含むものを除外--------------"
    mapM_ putStrLn $ map infoPath infos2


data Info = Info { infoPath :: FilePath,
                   infoPerms :: Maybe Permissions,
                   infoSize :: Maybe Integer,
                   infoModTime :: Maybe UTCTime} deriving (Eq, Ord, Show)

getInfo :: FilePath -> IO Info
getInfo path = do
    perms <- maybeIO (getPermissions path)
    size <- maybeIO (bracket (openFile path ReadMode) hClose hFileSize)
    modified <- maybeIO (getModificationTime path)
    return (Info path perms size modified)

maybeIO :: IO a -> IO (Maybe a)
maybeIO act = handle nothing (Just `liftM` act)

nothing :: SomeException -> IO (Maybe a)
nothing _ = return Nothing

traverse :: ([Info] -> [Info]) -> FilePath -> IO [Info]
traverse order path = do
    names <- getUsefulContents path
    contents <- mapM getInfo (path:map (path </>) names)
    liftM concat $ forM (order contents) $ \info -> do
        if isDirectory info && infoPath info /= path
        then traverse order (infoPath info)
        else return [info]

traverseP :: ([Info] -> [Info]) -> (Info -> Bool) -> FilePath ->
                   IO [Info]
traverseP order p path = do
    infos <- traverse order path
    return (filter p infos)


getUsefulContents :: FilePath -> IO [String]
getUsefulContents path = do
    names <- getDirectoryContents path
    return (filter (`notElem` [".", ".."]) names)

isDirectory :: Info -> Bool
isDirectory = maybe False searchable . infoPerms

-- 帰りがけ順(子ディレクトリが親ディレクトリより先に返る)に操作する制御関数
order1 :: [Info] -> [Info]
order1 = foldr (\i acc -> if isDirectory i then acc ++ [i] else i:acc) []

-- 
testP :: Info -> Bool
testP info = not $ "temp" `isInfixOf` (infoPath info)

入出力結果(Terminal, runghc)

$ runghc ControlledVisit.hs 
id--------------------------------------
../
../blog.html
../CC.hs
../ch03
../ch03/Intersperse.hs
../ch03/Tree.hs
../ch05
../ch05/Main.hi
../ch05/Main.hs
../ch05/Main.o
../ch05/Prettify.hs
../ch05/PrettyJSON.hs
../ch05/PutJSON.hs
../ch05/simple
../ch05/SimpleJSON.hi
../ch05/SimpleJSON.hs
../ch05/SimpleJSON.o
../ch08
../ch08/Glob.hs
../ch08/GlobRegex.hs
../ch09
../ch09/BetterPredicate.hs
../ch09/ControlledVisit.hs
../ch09/temp1_folder
../ch09/temp1_folder/temp11_folder
../ch09/temp1_folder/temp11_folder/temp111_folder
../ch09/temp1_folder/temp11_folder/temp112_folder
../ch09/temp1_folder/temp12_folder
../ch09/temp2_folder
../exercises.hs
../GrahamScan.hs
../InteractWith
../InteractWith.hi
../InteractWith.hs
../InteractWith.o
../mypretty
../mypretty/JSONClass.hs
../output.txt
../quux.txt
../SafeList.hs
../Sample.hs
../temp.txt
../WC.hs
パス名にtempを含むものを除外--------------
../
../blog.html
../CC.hs
../ch03
../ch03/Intersperse.hs
../ch03/Tree.hs
../ch05
../ch05/Main.hi
../ch05/Main.hs
../ch05/Main.o
../ch05/Prettify.hs
../ch05/PrettyJSON.hs
../ch05/PutJSON.hs
../ch05/simple
../ch05/SimpleJSON.hi
../ch05/SimpleJSON.hs
../ch05/SimpleJSON.o
../ch08
../ch08/Glob.hs
../ch08/GlobRegex.hs
../ch09
../ch09/BetterPredicate.hs
../ch09/ControlledVisit.hs
../exercises.hs
../GrahamScan.hs
../InteractWith
../InteractWith.hi
../InteractWith.hs
../InteractWith.o
../mypretty
../mypretty/JSONClass.hs
../output.txt
../quux.txt
../SafeList.hs
../Sample.hs
../WC.hs
$