できた

こっちが昨日書き直したFind。

- Find.hs
module Find where

import Control.Monad
import System.Directory

find :: String -> (FilePath -> Bool) -> IO [FilePath]
find dir f = return . filter f =<< (ls_r dir)
  where
    ls_r [] = return []
    ls_r dir = do
      all  <- getDirectoryContents dir >>= return . filter notParentAndCurrent
      let all' = map (add dir) all
        in do
             dirs <- filterM doesDirectoryExist all'
             mapM ls_r dirs >>= return . (++ all') . concat
    notParentAndCurrent = \x -> and $ map (/= x) ["..", "."]
    add = (++) . flip (++) "/"

こっちが書き直したMain。引数とってくるところはメンドーだから手抜きした。引数とってくる処理なんて飾りです。偉い人には解からんのです。

- HVMain.hs
module Main where

import Text.Regex
import System
import System.IO
import Control.Monad
import Find (find)

main = do
  (libDir:func:_) <- getArgs
  ret <- find libDir isHs >>= (mapM . view) func >>= return . filter (/= [])
  mapM_ putStrLn ret
  where
    isHs = \x -> reverse (take 3 (reverse x)) == ".hs"

view :: String -> FilePath -> IO String
view func path = do
  str <- search (myRegex func) =<< readFile path
  if str == ""
     then return ""
     else return $ ("--" ++ path ++ "\n") ++ str
  where
    myRegex func = mkRegexWithOpts ("^" ++ func ++ " (.+\n)+(^$){1}?") True True    search re c = do
      case matchRegexAll re c of
        Just (_,x,y,_) -> return . (++) x =<< search re y
        _              -> return ""

なんだかrunghcで動かないので、真面目にコンパイルする。

$ ghc -o HVMain Find.hs HVMain.hs

できたー。正規表現をいじったから"hPutStLn"なんかもちゃんと出せるようになった。

$ ./HVMain /usr/lib/hugs/libraries foldr
--/usr/lib/hugs/libraries/Hugs/Prelude.hs
foldr            :: (a -> b -> b) -> b -> [a] -> b
foldr f z []      = z
foldr f z (x:xs)  = f x (foldr f z xs)

runghcで起動するとGC(ガベージコレクタ)がウンタラ言われる。GHCの構造とかもちゃんと勉強していきたいなぁ、と思う。