HaHaHa!(old)

blogを内容毎に分けていたのだけれど、たまにしか更新しないのでほとんど意味がない。HaHaHa!に書いていた内容はhttp://d.hatena.ne.jp/nobsun/で書くことにします．ここは記録としてそのまま残します．

■ 「Haskellによる関数プログラミング」ご案内

2009-03-20（金祝）にjus勉強会「Haskellによる関数プログラミング」で講師をします．

日時：2009年3月20日（金祝）

場所：稚内北星学園大学東京サテライト校（秋葉原ダイビル12階）

以下のところに案内があり，そこから申し込みのページに飛べるようになっています

http://www.jus.or.jp/benkyokai/09-03Haskell.html

よろしくお願いいたします．

■ 「思考の流れ」

思考の流れについて - or1ko's diary

Inemuri nezumi diary(2009-02-07)

経由で知った．

puts ARGF.each.take (n)

puts と ARGF.each.take (n) との関係が思考のながれとは逆な希ガス．:)

take と (n) との関係も... :)

というのさておき，オブジェクト指向と日本語思考の類似性は確かにある．つForth

Haskell的なのは

import System.Environment

n = 5

main = putStr . unlines . take n . lines =<< rbARGF

rbARGF :: IO String
rbARGF = mkARGF =<< getArgs

mkARGF :: [String] -> IO String
mkARGF []   = getContents
mkARGF argv = return . concat =<< mapM readFile argv

かな．

mainちゅうのはや，文字列を出力する(putStr)もんなんや，でなその文字列ちゅうのはなんぼかの行を束ねた(unlines)もんやねん．なんぼかの行ちゅうたってたいしたことあらへん5行取ってきた(take n)だけやさかい．ほんでなどこから取ってきたちゅうたらな，なんか長い文字列があったのをな改行で行にバラした(lines)もんなんやて．そんでな，元の長い文字列ちゅうのはやな，rbARGFがどこぞからカッパラってきたもんらしいで．

いやぁー，こちらどないしても，Ruby風がよろしいいうたはりますえ．

import Prelude hiding ((.))
import ARGF (rbARGF)

infixl 9 .
(.) :: (a -> b) -> (b -> c) -> (a -> c)
(f . g) x = g (f x)

n = 5

main :: IO ()
main = rbARGF >>= lines . take n . unlines . putStr

はぁ，はんなりしてはって，よろしいちゃいますか．まぁむずかしいお話はこのへんにしといて，ぶぶづけでもどうどす．新幹線？そんなん待たしといたらよろしやんか．そうどすかぁ？また，いつでもすきなときに来てくれはったらよろしいわ．休みの日？今日かて来はってんから，叩きおこしくれはったらよろしで．．．

■ 同じもの，違うもの，似たもの

Haskellを使ってプログラミングするとき，「同じものには同じ名前，違うものには違う名前を」ということを意識してやっているような気がする．意識してやってるが，意識してやることは無意識にやっている．そうすることが，ポリシーだとか，こだわりだとか，そういうものとしては意識していない．

そう考えるのはHaskellだからか．そんなことはなさそうだ．

「同じものには同じ名前，違うものには違う名前を」というのはプログラミング全般に通じる話だ．それどころかものを考えるときに共通する話だ．

でもとにかく，Haskellでプログラミングするときの話として考えてもらえばいいかな．

同じものというのは意外に分りにくい．同じとも，違うともいえそうな「似ている」ものというのが沢山ある．そういう時，名前はどうするか．この場合は，同じところと，違うところを分別して，違うところを同じところに対してパラメータ化する．

値の話なら関数ができるというわけだ．型の話なら引数をとる型構成子というわけですな．

プログラムができてしまうと，トップダウンで関数がでてくるように見てしまう．実際には頭の中で，非常に泥くさいコードを沢山書きすてている．このようなボトムアップがあるので自分ではちゃんと考えてプログラムを書いた気になれる．

でもこまったことに，その泥くさい過程があることをわすれてしまって，最初からトップダウンに定義したように勘違いしていることがよくある．他人にもいかにも最初からトップダウンで抽象的に考えたかのように説明してしまう．どうしたらそういうプログラムになるのかと尋ねられても，最初からトップダウンで考えればいいよ．などといってしまう．

...つづきはあとで書く...というか、考えなおしするつもり．

■ グローバル変数（続）

Haskell でグローバル変数が欲しい理由 - あどけない話にコメントしたものにコメントがありましたが、コメント欄に大量に書くのは読みにくいかもしれないので、コメントへのコメントへのコメントではありますが、こちらに書いてしまいます。

...、直観的に言えば、煩雑で面倒だろうなと思います。

argvをグローバル変数として

main = putStr func1

func1 = func2
func2 = func3
func3 = func4
func4 = if "-c" `elem` argv then "ASCII" else "HEX"

と書くのと

main = putStr . func1 . elem "-c" =<< getArgs

func1 = func2
func2 = func3
func3 = func4
func4 cflag = if cflag then "ASCII" else "HEX"

と書くのとで煩雑、面倒という点での違いがわかりませんでした。

私の場合、値が変化する変数が嫌だなと思う理由は、考えなければいけないことが多くなって面倒で煩雑だからです。Haskellでは変数は「変」数ではなく、値（を表わす式）についた名前です。したがって、同じ有効範囲では、名前はいつでも同じ値でないと面倒で煩雑なのです。何かの値に応じて変化するものであるなら、その何かをパラメータとして関数で表現します。そういう原則に反したコードがあると読むのが苦痛になります。

自分が書くときは、好き嫌い以前に、そもそも欲しいとか、ないと煩雑だとか面倒だとか思わないのです。これはHaskellで書く習慣がついたからだろうと思っています。どうしてグローバル変数が欲しいのか、それがないと煩雑、面倒だという感覚を忘れていまっているのです。それで逆に興味があったわけです。

コマンドラインオプションは*不変*の環境であり、どの関数からも直接アクセスできてしかるべきだ、...

コマンドラインオプションが実際に渡ってきたところ、つまり main の中では*不変*の環境ですが、main の外ではそうではないですよね。

値が変わりうるグローバル変数は忌み嫌われますが、グローバル定数を嫌う理由はないと思っています。

私は、グローバル定数を嫌うわけではなくて（Haskellではトップレベルの名前はすべてグローバル定数です）、コマンドラインオプションはグローバル定数ではないという感覚をもっているので違和感があるわけです。

■ スクリプトとは

g:haskell:id:nobsun:20090113:p1を考えていたときに、同時にスクリプトというのはなんだろうと考えて書いたのが、System.Scriptというモジュールです。 Haskell でスクリプトを書く - HaHaHa!(old) - haskell

スクリプトは以下の３つの要素に抽象できると考えています（すこし単純にしています）。

1. 内部でデータ変換 :: a -> b
2. 外界からの入力アクション :: IO a
3. 外界への出力アクション :: b -> IO ()

３つの構成要素の振る舞いは、

1. プログラマの意図 :: class Script
2. スクリプト起動時に外界から与えられるメタ情報 :: (Name,Env,ParsedArgs c)

に依存します。外界からの情報というのは、プログラム名、環境（環境変数名と値の連想リスト）、コマンドライン引数（のパーズ結果）の３つ組と考えていいでしょう。プログラマの意図はまさにスクリプトの内容ですね。これをコードで表わしたのが、 Haskell でスクリプトを書く - HaHaHa!(old) - haskellです。

copy

標準入力を標準出力にコピーするだけの copy というスクリプトなら

{-# LANGUAGE MultiParamTypeClasses, EmptyDataDecls, TypeSynonymInstances #-}
module Main where

import System.Script

main :: IO ()
main = runScript copy =<< meta undefined

data CopyType a b c
type Copy = CopyType String String ()

copy :: Copy
copy = copy

instance Script CopyType String String () where
  mkinput  _ _ = getContents
  mkoutput _ _ = putStr
  mkproc   _ _ = id

cat

上のcopy例は自明な例で、System.Scriptを使うまでもなく、

main = interact id

というたった１行で済んでしまいますが、それでも Script にあてはめることができるということを示した例です。もうすこし手の込んだ例もあげましょう。

以下はLinuxのcatをパフォーマンスはあまり考えずに実装した例です。あまり美しくは書けていませんので煩雑ですが、コマンド引数あるいはオプションのパーズ結果を引き回すことになったからという理由ではないはずです。

{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, EmptyDataDecls, TypeSynonymInstances #-}
module Main where

import Control.Arrow
import Control.Monad
import Data.Array
import Data.Char
import Data.List
import Data.Version
import System.Environment
import System.Console.GetOpt
import Text.Printf

import System.Script

------------------------------------------------------------------------------

main :: IO ()
main = runScript cat =<< meta argsParser

------------------------------------------------------------------------------

version :: Version
version  = Version [0,1] ["ghc","6.10.1"]

------------------------------------------------------------------------------
-- arguments anlyzer

data Options = Options
  { optNumberNonBlank  :: Bool
  , optShowEnds        :: Bool
  , optNumber          :: Bool
  , optSqueezeBlank    :: Bool
  , optShowTabs        :: Bool
  , optShowNonPrinting :: Bool
  , optHelp            :: Bool
  , optVersion         :: Bool
  }

defaultOptions :: Options
defaultOptions = Options
  { optNumberNonBlank  = False
  , optShowEnds        = False
  , optNumber          = False
  , optSqueezeBlank    = False
  , optShowTabs        = False
  , optShowNonPrinting = False
  , optHelp            = False
  , optVersion         = False
  }

options :: [OptDescr (Options -> Options)]
options = [ Option ['A'] ["show-all"]
                   (NoArg (\ opts -> opts { optShowNonPrinting  = True
                                          , optShowEnds         = True
                                          , optShowTabs         = True
                                          }))
                   "equivalent to -vET"
          , Option ['b'] ["number-nonblank"]
                   (NoArg (\ opts -> opts { optNumberNonBlank  = True }))
                   "number nonempty output lines"
          , Option ['e'] []
                   (NoArg (\ opts -> opts { optShowNonPrinting  = True
                                          , optShowEnds         = True
                                          }))
                   "equivalent to -vE"
          , Option ['E'] ["show-ends"]
                   (NoArg (\ opts -> opts { optShowEnds  = True }))
                   "display $ at end of each lines"
          , Option ['n'] ["number"]
                   (NoArg (\ opts -> opts { optNumber  = True }))
                   "number all output lines"
          , Option ['s'] ["squeeze-blank"]
                   (NoArg (\ opts -> opts { optSqueezeBlank = True }))
                   "suppress repeated empty output lines"
          , Option ['t'] [] 
                   (NoArg (\ opts -> opts { optShowNonPrinting  = True
                                          , optShowTabs         = True
                                          }))
                   "equivalent to -vT"
          , Option ['T'] ["show-tabs"]
                   (NoArg (\ opts -> opts { optShowTabs  = True }))
                   "display TAB characters as ^I"
          , Option ['u'] []
                   (NoArg id)
                   "(ignored)"
          , Option ['v'] ["show-nonprinting"]
                   (NoArg (\ opts -> opts { optShowNonPrinting = True }))
                   "use ^ and M- notation, except for LFD and TAB"
          , Option [] ["help"]
                   (NoArg (\ opts -> opts { optHelp = True }))
                   "display this help and exit"
          , Option [] ["version"]
                   (NoArg (\ opts -> opts { optVersion = True }))
                   "output version information and exit"
          ]

argsParser :: ArgsParser (Options -> Options)
argsParser = getOpt RequireOrder options

------------------------------------------------------------------------------
-- instance of Script

data CatType a b c

type CatOpt = Options -> Options
type Cat = CatType String String CatOpt

type CatMeta = Meta CatOpt

type CatInput  = Input  String
type CatOutput = Output String
type CatProc   = Proc String String

cat :: Cat
cat = cat

instance Script CatType String String CatOpt where
  mkinput  = catInput
  mkoutput = catOutput
  mkproc   = catProc

------------------------------------------------------------------------------

catInput :: Cat -> CatMeta -> CatInput
catInput _ (p,_,m)
 = case m of
     (_,[],[]) -> getContents
     (_,fs,[]) -> return . concat =<< mapM readFile' fs
     (_, _,es) -> ioError $ userError $ unlines es ++ usageInfo (header p) options
     where readFile' "-" = readFile "/dev/stdin"
           readFile' fn  = readFile fn

catOutput :: Cat -> CatMeta -> CatOutput
catOutput _ (p,_,m)
 = case m of
     (o,_,_) -> if optHelp opts then const $ putStr (usageInfo (header p) options)
                else if optVersion opts then const 
                         $ putStrLn (p ++ showVersion version)
                else putStr
                where opts = foldl (flip id) defaultOptions o

catProc :: Cat -> CatMeta -> CatProc
catProc   _ (p,_,m)
 = case m of
     (o,_,_) -> if optNumberNonBlank opts then nbNumber  sq 1 (trans opts)
                else if optNumber opts    then allNumber sq 1 (trans opts)
                                          else noNumber  sq   (trans opts)
                where opts = foldl (flip id) defaultOptions o
                      sq   = optSqueezeBlank opts

header :: String -> String
header p = "Usage: "++p++" [OPTION...] files..."

------------------------------------------------------------------------------
-- string processor

foldrrev :: (a -> b -> b) -> [a] -> b -> b
foldrrev f = flip (foldr f)

noNumber :: Bool -> (Char -> String -> String) -> String -> String
noNumber b f s 
  | not b     = foldrrev f s ""
  | otherwise = case break ('\n'==) s of
      (_,"")         -> foldrrev f s ""
      (xs,_:'\n':ys) -> foldrrev f xs $ foldrrev f "\n\n"
                      $ noNumber b f (dropWhile ('\n'==) ys)
      (xs,_:ys)      -> foldrrev f xs $ f '\n' $ noNumber b f ys

allNumber :: Bool -> Int -> (Char -> String -> String) -> String -> String
allNumber b i f s  = case break ('\n'==) s of
 ("",""  )      -> s
 (_ ,""  )      -> printf "%6d  %s" i $ foldrrev f s ""
 (xs,_:'\n':ys) -> printf "%6d  %s" i 
                 $ foldrrev f xs
                 $ f '\n'
                 $ printf "%6d  %s" (i+1) 
                 $ f '\n'
                 $ allNumber b (i+2) f 
                 $ if b then dropWhile ('\n'==) ys else ys
 (xs,_:ys)      -> printf "%6d  %s" i
                 $ foldrrev f xs
                 $ f '\n'
                 $ allNumber b (i+1) f ys

nbNumber :: Bool -> Int -> (Char -> String -> String) -> String -> String
nbNumber b i f s = case break ('\n'==) s of
 ("",""  )      -> s
 ("",_:'\n':ys) -> f '\n'
                 $ f '\n'
                 $ nbNumber b i f 
                 $ if b then dropWhile ('\n'==) ys else ys
 ("",_:ys)      -> f '\n' $ nbNumber b i f ys
 (_ ,""  )      -> printf "%6d  %s" i $ foldrrev f s ""
 (xs,_:'\n':ys) -> printf "%6d  %s" i
                 $ foldrrev f xs
                 $ foldrrev f "\n\n"
                 $ nbNumber b (i+1) f 
                 $ if b then dropWhile ('\n'==) ys else ys
 (xs,_:ys)      -> printf "%6d  %s" i 
                 $ foldrrev f xs
                 $ f '\n'
                 $ nbNumber b (i+1) f ys

defaultTable :: Array Char ShowS
defaultTable = listArray (chr 0, chr 255) $ map ((:) . chr) [0 .. 255]

showEnds, showTabs, showNonPrinting :: [(Char,ShowS)]
showEnds = [('\n',('$':) . ('\n':))]
showTabs = [('\t',('^':) . ('I':))]
showNonPrinting = map (id &&& dispChar) 
                $ (\\ "\t\n") 
                $ filter (not . isAsciiPrint) 
                $ map chr [0..255]

isAsciiPrint :: Char -> Bool
isAsciiPrint c = isPrint c && isAscii c

dispChar c | isAsciiPrint c  = (c:)
           | ord c == 127    = ('^':) . ('?':)
           | isAscii c       = ('^':) . (chr (ord '@' + ord c) :)
           | otherwise       = ('M':) . ('-':) . dispChar (chr (ord c - 128))

trans :: Options -> Char -> ShowS
trans o = (tab !) 
  where tab = foldl' (//) defaultTable [e,t,n]
        e = if optShowEnds        o then showEnds        else []
        t = if optShowTabs        o then showTabs        else []
        n = if optShowNonPrinting o then showNonPrinting else []

■ Haskell でスクリプトを書く

ための簡単なフレームワークのつもり

{-# LANGUAGE MultiParamTypeClasses #-}
module System.Script where

import System.Environment

type Proc   a b  = a -> b
type Input  a    = IO a
type Output a    = a -> IO ()

class Script t a b c where
  mkinput  :: t a b c -> Meta c -> Input  a -- make input   action
  mkoutput :: t a b c -> Meta c -> Output b -- make output  action
  mkproc   :: t a b c -> Meta c -> Proc a b -- make convert function (a -> b)

type Name = String
type Var  = String
type Val  = String
type Env  = [(Var,Val)]
type Arg  = String
type Args = [Arg]
type Msg  = String
type Msgs = [String]

type ParsedArgs a = ([a]   -- parsed options
                    ,Args  -- non-option arguments
                    ,Msgs) -- messages for error during parsing arguments

type ArgsParser a  = Args -> ParsedArgs a

type Meta a = (Name,Env,ParsedArgs a) -- Meta information for script

runScript :: Script t a b c => t a b c -> Meta c -> IO ()
runScript x m = output . proc  =<< input
   where (output, proc, input) = (mkoutput x m, mkproc x m, mkinput x m)

meta :: ArgsParser a ->  IO (Meta a)
meta p = getProgName     >>= \ n ->
         getEnvironment  >>= \ e ->
         getArgs         >>= \ a ->
         return (n,e,p a)

■ グローバル変数

HaskellとgetOpt - あどけない話がとても興味深い。

興味があるのは、unsafePerformIOの話ではなく、グローバル変数が欲しいという感覚がどこから来ているのかだ。

• main で getArgs を使うと、コマンドライン・オプションの処理結果(cflag など)を下位の関数にずっと渡していかないといけない

というのがその源だと思うが、直前にあるコード例では、「処理結果(cflag など)を下位の関数にずっと渡していかないといけない」部分が省略されているようでよくわからない。