HaHaHa!(old)

2009-01-13

グローバル変数(続)

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

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

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

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

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

に依存します。外界からの情報というのは、プログラム名、環境(環境変数名と値の連想リスト)、コマンドライン引数(のパーズ結果)の3つ組と考えていいでしょう。プログラマの意図はまさにスクリプトの内容ですね。これをコードで表わしたのが、 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

というたった1行で済んでしまいますが、それでも 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 []

AkiraAkira2012/07/24 07:33Your articles are for when it abosluetly, positively, needs to be understood overnight.