Real World Haskell
実戦で学ぶ関数型言語プログラミング
Bryan O'Sullivan, John Goerzen, Don Stewart(著)
山下 伸夫, 伊東 勝利
株式会社タイムインターメディア(翻訳)
開発環境
- OS X Lion - Apple(OS)
- BBEdit - Bare Bones Software, Inc.(Text Editor)
- プログラミング言語: Haskell (純粋関数型)
Real World Haskell』(Bryan O'Sullivan、John Goerzen、Don Stewart(著)、山下 伸夫、伊東 勝利、株式会社タイムインターメディア(翻訳)、オライリー・ジャパン、2009年、ISBN978-4-87311-423-3)の8章(効率的なファイル処理、正規表現、ファイル名マッチング)の8.7(作成したパターン照合器を使う)の練習問題3.を解いてみる。
3.
コード(BBEdit)
GlobRegex.hs
-- file: GlobRegex.hs
module GlobRegex
(
globToRegex
, matchesGlob
) where
import Data.Char (toUpper)
import Text.Regex.Posix ((=~))
-- Trueの場合は大文字小文字を区別しない
-- Flaseの場合は大文字小文字を区別する
type Ignore = Bool
globToRegex :: String -&lgt; Ignore -&lgt; String
globToRegex cs i | i = '^': (map toUpper (globToRegex' cs)) ++ "$"
| otherwise = '^': globToRegex' cs ++ "$"
globToRegex' :: String -&lgt; String
globToRegex' "" = ""
-- 拡張ワイルドカード構文用に追加
globToRegex' ('*':'*':cs) = ".*" ++ globToRegex' cs
globToRegex' ('*':cs) = ".*" ++ globToRegex' cs
globToRegex' ('?':cs) = '.' : globToRegex' cs
globToRegex' ('[':'!':c:cs) = "[^" ++ c:charClass cs
globToRegex' ('[':c:cs) = '[':c:charClass cs
globToRegex' ('[':_) = error "unterminated character class"
globToRegex' (c:cs) = escape c ++ globToRegex' cs
escape :: Char -&lgt; String
escape c | c `elem` regexChars = '\\':[c]
| otherwise = [c]
where regexChars = "\\+()^$.{}]|"
charClass :: String -&lgt; String
charClass (']':cs) = ']' : globToRegex' cs
charClass (c:cs) = c: charClass cs
charClass [] = error "unterminated character class"
matchesGlob :: Ignore -&lgt; String -&lgt; FilePath -&lgt; Bool
matchesGlob i pat name | i = (map toUpper name) =~ globToRegex pat i
| otherwise = name =~ globToRegex pat i
Glob.hs
-- file: Glob.hs
module Glob (namesMatching) where
import Data.List (isInfixOf)
import System.Directory (doesDirectoryExist, doesFileExist,
getCurrentDirectory, getDirectoryContents)
import System.FilePath (dropTrailingPathSeparator, splitFileName, (</&lgt;), pathSeparator)
import System.Posix.Files (fileExist)
-- Control.Exceptionだと上手くいかなかったのでOldExceptionに修正
-- ただし、将来のバージョンでは使えなくなるみたい(その旨が警告された)
-- かといって、今のところ修正方法が分からない。。
import Control.OldException (handle)
import Control.Monad (forM)
import GlobRegex (matchesGlob)
isPattern :: String -&lgt; Bool
isPattern = any (`elem`"[*?")
-- 拡張ワイルドカード構文か調べる
isDeep :: String -&lgt; Bool
isDeep = isInfixOf "**"
namesMatching pat i
| not (isPattern pat) = do
-- 書き換えた箇所
exists <- fileExist pat
return (if exists then [pat] else [])
-- 拡張ワイルドカード構文の場合
| isDeep pat = do
names <- getAllFileNames $ head pat
return (filter (matchesGlob i pat) names)
| otherwise = do
case splitFileName pat of
("", baseName) -&lgt; do
curDir <- getCurrentDirectory
listMatches curDir baseName
(dirName, baseName) -&lgt; do
dirs <- if isPattern dirName
then namesMatching (dropTrailingPathSeparator dirName) i
else return [dirName]
let listDir = if isPattern baseName
then listMatches
else listPlain
pathNames <- forM dirs $ \dir -&lgt; do
baseNames <- listDir dir baseName
return (map (dir </&lgt;) baseNames)
return (concat pathNames)
getAllFileNames :: Char -&lgt; IO [FilePath]
getAllFileNames c = do
contents <- getDirectoryContents "."
getAllFileNames' (return []) "" contents
where start | c == pathSeparator = [pathSeparator]
| otherwise = "."
pre | c == pathSeparator = [pathSeparator]
| otherwise = ""
getAllFileNames' :: IO[FilePath] -&lgt; FilePath -&lgt; [FilePath] -&lgt; IO [FilePath]
getAllFileNames' x _ [] = x
getAllFileNames' x pre (f:fs) | f == "." = getAllFileNames' x pre fs
| f == ".." = getAllFileNames' x pre fs
| otherwise = do
exists <- doesDirectoryExist (pre ++ f)
contents <- if exists
then getDirectoryContents (pre ++ f)
else return []
if exists
then do
rest <- (getAllFileNames' x pre fs)
recur <- (getAllFileNames' (return []) (pre ++ f ++ [pathSeparator]) contents)
return (rest ++ recur)
else do
x' <- x
getAllFileNames' (return ((pre ++ f):x')) pre fs
{-
doesNameExist :: FilePath -&lgt; IO Bool
doesNameExist name = do
fileExists <- doesFileExist name
if fileExists
then return True
else doesDirectoryExist name
-}
listMatches :: FilePath -&lgt; String -&lgt; IO [String]
listMatches dirName pat = do
dirName' <- if null dirName
then getCurrentDirectory
else return dirName
handle (const (return [])) $ do
names <- getDirectoryContents dirName'
let names' = if isHidden pat
then filter isHidden names
else filter (not . isHidden) names
-- ここのpathSeparatorでUNIXかWindowsか判定
let i = if pathSeparator == '/'
then True
else False
return (filter (matchesGlob i pat) names')
isHidden :: String -&lgt; Bool
isHidden ('.':_) = True
isHidden _ = False
listPlain :: FilePath -&lgt; String -&lgt; IO [String]
listPlain dirName baseName = do
exists <- if null baseName
then doesDirectoryExist dirName
-- 書き換えた箇所
else fileExist (dirName </&lgt; baseName)
return (if exists then [baseName] else [])
入出力結果(Terminal, ghci)
$ ghci
GHCi, version 7.4.2: http://www.haskell.org/ghc/ :? for help
Loading package ghc-prim ... linking ... done.
Loading package integer-gmp ... linking ... done.
Loading package base ... linking ... done.
Prelude> :load Glob
[1 of 2] Compiling GlobRegex ( GlobRegex.hs, interpreted )
[2 of 2] Compiling Glob ( Glob.hs, interpreted )
Glob.hs:12:1:
Warning: Module `Control.OldException' is deprecated:
Future versions of base will not support the old exceptions style. Please switch to extensible exceptions.
Glob.hs:12:30:
Warning: In the use of `handle'
(imported from Control.OldException):
Deprecated: "Future versions of base will not support the old exceptions style. Please switch to extensible exceptions."
Ok, modules loaded: Glob, GlobRegex.
*Glob> namesMatching "*.txt" False
Loading package array-0.4.0.0 ... linking ... done.
Loading package bytestring-0.9.2.1 ... linking ... done.
Loading package deepseq-1.3.0.0 ... linking ... done.
Loading package containers-0.4.2.1 ... linking ... done.
Loading package transformers-0.3.0.0 ... linking ... done.
Loading package mtl-2.1.2 ... linking ... done.
Loading package regex-base-0.93.2 ... linking ... done.
Loading package regex-posix-0.95.2 ... linking ... done.
Loading package filepath-1.3.0.0 ... linking ... done.
Loading package old-locale-1.0.0.4 ... linking ... done.
Loading package old-time-1.1.0.0 ... linking ... done.
Loading package unix-2.5.1.1 ... linking ... done.
Loading package directory-1.1.0.2 ... linking ... done.
["./gpl-3.0.txt","./hello-in.txt","./in.txt","./input.txt","./out.txt","./out_tmp.txt","./output.txt","./quux.txt","./Scratchpad.txt","./tmp.txt"]
*Glob> namesMatching "**.txt" False
["tmp.txt","Scratchpad.txt","quux.txt","output.txt","out_tmp.txt","out.txt","input.txt","in.txt","hello-in.txt","gpl-3.0.txt","sample_folder/tmp.txt"]
*Glob> :quit
Leaving GHCi.
$
エラー、修正の繰り返しで途中から自分自身でも何を書いてるのか分からなくなったけど、結果だけ見ると、とりあえずはこれで合ってるのかな。。
0 コメント:
コメントを投稿