Haskell - コード事例研究: バイナリデータフォーマットの構文解析(PGMファイル(プレーンファイル)の構文解析器(エラーメッセージの報告(Maybe a型をEither a b型に変更)))

Real World Haskell
実戦で学ぶ関数型言語プログラミング
(オライリージャパン)
Bryan O'Sullivan (著) John Goerzen (著)
Don Stewart (著)
山下伸夫 (翻訳) 伊東勝利 (翻訳)
株式会社タイムインターメディア (翻訳)

開発環境

OS X Mavericks - Apple(OS)
BBEdit - Bare Bones Software, Inc., Emacs (Text Editor)
Haskell (純粋関数型プログラミング言語)
GHC (The Glasgow Haskell Compiler) (処理系)
The Haskell Platform (インストール方法、モジュール等)

Real World Haskell―実戦で学ぶ関数型言語プログラミング(Bryan O'Sullivan (著)、 John Goerzen (著)、 Don Stewart (著)、山下伸夫 (翻訳)、伊東勝利 (翻訳)、株式会社タイムインターメディア (翻訳)、オライリージャパン)の10章(コード事例研究: バイナリデータフォーマットの構文解析)、10.4(暗黙の状態)、10.4.1(恒等構文解析器)、10.4.4(解析状態の取得と変更)、10.9(今後の方向性)の練習問題 1.を解いてみる。

その他参考書籍

すごいHaskellたのしく学ぼう!(オーム社) Miran Lipovača(著)、田中英行、村主崇行(翻訳)
プログラミングHaskell (オーム社) Graham Hutton(著) 山本和彦(翻訳)

練習問題 1.

前回までのコード。

コード(BBEdit, Emacs)

ParseP2.hs

{-# OPTIONS -Wall -Werror #-}
module ParseP2 where

import Control.Applicative ((<$>))
import Data.Char (isSpace, isDigit)
import System.Environment (getArgs)

main :: IO ()
main = do
    (a:_) <- getArgs
    contents <- readFile a
    putStrLn "グレースケールファイル内容"
    putStr contents
    putStrLn "幅、高さ、最大グレー値"
    let g = runParse parseP2 $ ParseState contents
    print $ fmap fst g
    putStrLn "データ"
    print $ greyData <$> fst <$> g

data GreymapP2 = GreymapP2 {greyWith :: Int,
                            greyHeight :: Int,
                            greyMax :: Int,
                            greyData :: [Int]}
                 deriving (Eq)

instance Show GreymapP2 where
    show (GreymapP2 w h m _) = "GreymapP2 " ++ show w ++ "x" ++ show h ++
                               " " ++ show m

data ParseState = ParseState {string :: String} deriving (Show)

-- 構文解析が失敗したらエラーメッセージを報告するように修正
newtype Parse a = Parse {
    runParse :: ParseState -> Either String (a, ParseState)}

identity :: a -> Parse a
identity a = Parse $ \s -> Right (a, s)

getState :: Parse ParseState
getState = Parse $ \s -> Right (s, s)

putState :: ParseState -> Parse ()
putState s = Parse $ \_ -> Right ((), s)

-- 構文解析のエラーの報告
bail :: String -> Parse a
bail err = Parse $ \s -> Left err

parseP2 :: Parse GreymapP2
parseP2 =
    parseHeader ==> \header -> skipSpaces ==>&
    assert (header == "P2")
           "invalid header(should be P2)" ==>&
    parseNat ==> \width -> skipSpaces     ==>&
    parseNat ==> \height -> skipSpaces    ==>&
    parseNat ==> \maxGrey -> skipSpaces   ==>&
    assert (maxGrey <= 255)
           "over 255 error"               ==>&
    parseInts (width * height) ==> \ns -> 
       identity (GreymapP2 width height maxGrey ns)

(==>) :: Parse a -> (a -> Parse b) -> Parse b
firstParser ==> secondParser = Parse chainedParser
    where chainedParser initState =
              case runParse firstParser initState of
                   Left errMessage -> Left errMessage
                   Right (firstResult, newState) ->
                       runParse (secondParser firstResult) newState

(==>&) :: Parse a -> Parse b -> Parse b
p ==>& f = p ==> \_ -> f

assert :: Bool -> String -> Parse ()
assert True _ = identity ()
assert False err = bail err

-- 構文解析器
skipSpaces :: Parse ()
skipSpaces =
    getState ==> \initState ->
        putState $
            initState {string = (dropWhile isSpace (string initState))}

parseHeader :: Parse String
parseHeader =
    getState ==> \initState ->
        let str = string initState
            header = takeWhile (not . isSpace) str
            newState = initState {
                string = drop (length header) str}
        in putState newState ==> \_ ->
               identity header

parseNat :: Parse Int
parseNat =
    getState ==> \initState ->
        let (num, str) = span isDigit (string initState)
            newState = initState { string = str}
        in putState newState  ==> \_ ->
               if null num
               then bail "parseNat error"
               else identity (read num :: Int)

parseInts :: Int -> Parse [Int]
parseInts n =
    getState ==> \initState ->
        case iter n (' ':string initState) [] of
             Nothing -> bail "parseInts error"
             Just (ns, _) ->
                 identity ns

iter :: Int -> String -> [Int] -> Maybe ([Int], ParseState)
iter n s ns
    | n == 0 && (null s || null (dropWhile isSpace s))
        = Just (ns, ParseState s)
    | n /= 0 && null s = Nothing
    | n /= 0 && (isSpace (head s)) =
        let (num, str) = span isDigit (tail s)
        in if null num
        then Nothing
        else iter (n - 1) str (ns ++ [read num :: Int])
    | otherwise = Nothing

入出力結果(Terminal, runghc)

$ runghc ParseP2.hs test_p2.pgm
グレースケールファイル内容
P2
24 7
15
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
0 3 3 3 3 0 0 7 7 7 7 0 0 11 11 11 11 0 0 15 15 15 15 0
0 3 0 0 0 0 0 7 0 0 0 0 0 11 0 0 0 0 0 15 0 0 15 0
0 3 3 3 0 0 0 7 7 7 0 0 0 11 11 11 0 0 0 15 15 15 15 0
0 3 0 0 0 0 0 7 0 0 0 0 0 11 0 0 0 0 0 15 0 0 0 0
0 3 0 0 0 0 0 7 7 7 7 0 0 11 11 11 11 0 0 15 0 0 0 0
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
幅、高さ、最大グレー値
Right GreymapP2 24x7 15
データ
Right [0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,3,3,3,3,0,0,7,7,7,7,0,0,11,11,11,11,0,0,15,15,15,15,0,0,3,0,0,0,0,0,7,0,0,0,0,0,11,0,0,0,0,0,15,0,0,15,0,0,3,3,3,0,0,0,7,7,7,0,0,0,11,11,11,0,0,0,15,15,15,15,0,0,3,0,0,0,0,0,7,0,0,0,0,0,11,0,0,0,0,0,15,0,0,0,0,0,3,0,0,0,0,0,7,7,7,7,0,0,11,11,11,11,0,0,15,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0]
$ runghc ParseP2.hs test_p5.pgm 
グレースケールファイル内容
P5
24 7
15
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
0 3 3 3 3 0 0 7 7 7 7 0 0 11 11 11 11 0 0 15 15 15 15 0
0 3 0 0 0 0 0 7 0 0 0 0 0 11 0 0 0 0 0 15 0 0 15 0
0 3 3 3 0 0 0 7 7 7 0 0 0 11 11 11 0 0 0 15 15 15 15 0
0 3 0 0 0 0 0 7 0 0 0 0 0 11 0 0 0 0 0 15 0 0 0 0
0 3 0 0 0 0 0 7 7 7 7 0 0 11 11 11 11 0 0 15 0 0 0 0
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
幅、高さ、最大グレー値
Left "invalid header(should be P2)"
データ
Left "invalid header(should be P2)"
$ runghc ParseP2.hs temp1.pgm 
グレースケールファイル内容
P2
24 7
256
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
0 3 3 3 3 0 0 7 7 7 7 0 0 11 11 11 11 0 0 15 15 15 15 0
0 3 0 0 0 0 0 7 0 0 0 0 0 11 0 0 0 0 0 15 0 0 15 0
0 3 3 3 0 0 0 7 7 7 0 0 0 11 11 11 0 0 0 15 15 15 15 0
0 3 0 0 0 0 0 7 0 0 0 0 0 11 0 0 0 0 0 15 0 0 0 0
0 3 0 0 0 0 0 7 7 7 7 0 0 11 11 11 11 0 0 15 0 0 0 0
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
幅、高さ、最大グレー値
Left "over 255 error"
データ
Left "over 255 error"
$ runghc ParseP2.hs temp2.pgm 
グレースケールファイル内容
P2
24 7
15
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
0 3 3 3 3 0 0 7 7 7 7 0 0 11 11 11 11 0 0 15 15 15 15 0
0 3 0 0 0 0 0 7 0 0 0 0 0 11 0 0 0 0 0 15 0 0 15 0
0 3 3 3 0 0 0 7 7 7 0 0 0 11 11 11 0 0 0 15 15 15 15 0
0 3 0 0 0 0 0 7 0 0 0 0 0 11 0 0 0 0 0 15 0 0 0 0
0 3 0 0 0 0 0 7 7 7 7 0 0 11 11 11 11 0 0 15 0 0 0 0
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
幅、高さ、最大グレー値
Left "parseInts error"
データ
Left "parseInts error"
$ runghc ParseP2.hs temp3.pgm 
グレースケールファイル内容
P2
haskell 7
15
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
0 3 3 3 3 0 0 7 7 7 7 0 0 11 11 11 11 0 0 15 15 15 15 0
0 3 0 0 0 0 0 7 0 0 0 0 0 11 0 0 0 0 0 15 0 0 15 0
0 3 3 3 0 0 0 7 7 7 0 0 0 11 11 11 0 0 0 15 15 15 15 0
0 3 0 0 0 0 0 7 0 0 0 0 0 11 0 0 0 0 0 15 0 0 0 0
0 3 0 0 0 0 0 7 7 7 7 0 0 11 11 11 11 0 0 15 0 0 0 0
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
幅、高さ、最大グレー値
Left "parseNat error"
データ
Left "parseNat error"
$ runghc ParseP2.hs temp4.pgm 
グレースケールファイル内容
P2
24 7
a
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
0 3 3 3 3 0 0 7 7 7 7 0 0 11 11 11 11 0 0 15 15 15 15 0
0 3 0 0 0 0 0 7 0 0 0 0 0 11 0 0 0 0 0 15 0 0 15 0
0 3 3 3 0 0 0 7 7 7 0 0 0 11 11 11 0 0 0 15 15 15 15 0
0 3 0 0 0 0 0 7 0 0 0 0 0 11 0 0 0 0 0 15 0 0 0 0
0 3 0 0 0 0 0 7 7 7 7 0 0 11 11 11 11 0 0 15 0 0 0 0
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
幅、高さ、最大グレー値
Left "parseNat error"
データ
Left "parseNat error"
$ runghc ParseP2.hs temp5.pgm 
グレースケールファイル内容
P2
24 7
15
0 a 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
0 3 3 3 3 0 0 7 7 7 7 0 0 11 11 11 11 0 0 15 15 15 15 0
0 3 0 0 0 0 0 7 0 0 0 0 0 11 0 0 0 0 0 15 0 0 15 0
0 3 3 3 0 0 0 7 7 7 0 0 0 11 11 11 0 0 0 15 15 15 15 0
0 3 0 0 0 0 0 7 0 0 0 0 0 11 0 0 0 0 0 15 0 0 0 0
0 3 0 0 0 0 0 7 7 7 7 0 0 11 11 11 11 0 0 15 0 0 0 0
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
幅、高さ、最大グレー値
Left "parseInts error"
データ
Left "parseInts error"
$

Kamimura's blog

ほしい物リスト

2014年2月28日金曜日

Haskell - コード事例研究: バイナリデータフォーマットの構文解析(PGMファイル(プレーンファイル)の構文解析器(エラーメッセージの報告(Maybe a型をEither a b型に変更)))

0 コメント:

コメントを投稿