Haskell - グロブパターンでファイル名とディレクトリ名を取得(可搬性(UNIX/Windows)を持たせる(System.FilePathのpathSeparator))

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(作成したパターン照合器を使う)の練習問題1.を解いてみる。

1.

コード(BBEdit)

GlobRegex.hsは以前の投稿、Haskell - グロブパターンを正規表現に翻訳する(大文字小文字の区別) | Kamimura's blogのと同じ。

Glob.hs

-- file: Glob.hs
module Glob (namesMatching) where

import System.Directory (doesDirectoryExist, doesFileExist,
                         getCurrentDirectory, getDirectoryContents)
import System.FilePath (dropTrailingPathSeparator, splitFileName, (), pathSeparator)
-- Control.Exceptionだと上手くいかなかったのでOldExceptionに修正
-- ただし、将来のバージョンでは使えなくなるみたい(その旨が警告された)
-- かといって、今のところ修正方法が分からない。。
import Control.OldException (handle)
import Control.Monad (forM)
import GlobRegex (matchesGlob)

isPattern :: String -> Bool
isPattern = any (`elem`"[*?")

namesMatching pat
    | not (isPattern pat) = do
      exists <- doesNameExist pat
      return (if exists then [pat] else [])
    | otherwise = do
      case splitFileName pat of
          ("", baseName) -> do
              curDir <- getCurrentDirectory
              listMatches curDir baseName
          (dirName, baseName) -> do
              dirs <- if isPattern dirName
                          then namesMatching (dropTrailingPathSeparator dirName)
                          else return [dirName]
              let listDir = if isPattern baseName
                                then listMatches
                                else listPlain
              pathNames <- forM dirs $ \dir -> do
                                baseNames <- listDir dir baseName
                                return (map (dir ) baseNames)
              return (concat pathNames)
doesNameExist :: FilePath -> IO Bool
doesNameExist name = do
    fileExists <- doesFileExist name
    if fileExists
      then return True
      else doesDirectoryExist name

listMatches :: FilePath -> String -> 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 -> Bool
isHidden ('.':_) = True
isHidden _ = False

listPlain :: FilePath -> String -> IO [String]
listPlain dirName baseName = do
    exists <- if null baseName
                then doesDirectoryExist dirName
                else doesNameExist (dirName  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:9: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:9: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 "*.hs"
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.
["./Exporting.hs","./Glob.hs","./GlobRegex.hs","./InteractWith.hs","./Prettify.hs","./PrettyJSON.hs","./PutJSON.hs","./Sample.hs","./SimpleJSON.hs","./Trouble.hs"]
*Glob> namesMatching "*.txt"
["./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 "../haskell/*"
["../haskell/Exporting.hs","../haskell/Glob.hs","../haskell/GlobRegex.hs","../haskell/gpl-3.0.txt","../haskell/haskell_kamimura_blog.html","../haskell/hello-in.txt","../haskell/in.txt","../haskell/input.txt","../haskell/InteractWith","../haskell/InteractWith.hi","../haskell/InteractWith.hs","../haskell/InteractWith.o","../haskell/out.txt","../haskell/out_tmp.txt","../haskell/output.txt","../haskell/Prettify.hs","../haskell/PrettyJSON.hs","../haskell/prices.csv","../haskell/PutJSON.hi","../haskell/PutJSON.hs","../haskell/PutJSON.o","../haskell/quux.txt","../haskell/Sample","../haskell/Sample.hi","../haskell/Sample.hs","../haskell/Sample.o","../haskell/SampleJSON","../haskell/Scratchpad.txt","../haskell/simple","../haskell/SimpleJSON.hi","../haskell/SimpleJSON.hs","../haskell/SimpleJSON.o","../haskell/tmp.txt","../haskell/Trouble.hs"]
*Glob> namesMatching "../hask*"
["../haskell"]
*Glob> :quit
Leaving GHCi.
$

WindowsでHaskellの環境の構築をしてないから、とりあえずUNIX(Mac)だけで使ってみた。