Error Monad (Exception Monad)

モナドのすべて Haskell におけるモナドプログラミングの理論と実践に関する包括的ガイドの Error モナドを写経してみました。

import Monad
import System
import Control.Monad.Error
import Char
import Debug.Trace

-- 表示できるように deriving Showを追加します。
data ParseError = Err {location::Int, reason::String} deriving Show

instance Error ParseError where
  noMsg    = Err 0 "Parse Error"
  strMsg s = Err 0 s

type ParseMonad = Either ParseError

インスタンスの noMsg と strMsg は使われていないのですが、とう使うのだろうかといろいろやってみました。

> (throwError $ strMsg "Hello,world!")::ParseMonad Integer
-- > Left (Err {location = 0, reason = "Hello,world!"})
> (throwError $ noMsg ):: Either ParseError Integer
-- > Left (Err {location = 0, reason = "Parse Error"})

parseHexDigit は Char c と位置情報 idx を受け取って c がヘキサキャラクタのときは Integerに変換し、それ以外のときは例外を発生させます。

parseHexDigit :: Char -> Int -> ParseMonad Integer
parseHexDigit c idx = if isHexDigit c 
                         then return (toInteger (digitToInt c))
                         else throwError (Err idx ("Invalid character '" ++ [c] ++ "'"))
{-
> parseHexDigit 'a' 3
-- > Right 10
> parseHexDigit 'g' 3
-- > Left (Err {location = 3, reason = "Invalid character 'g'"})
-}

parseHexは文字列単位で変換します。

parseHex :: String -> ParseMonad Integer
parseHex s = parseHex' s 0 1

-- > parseHex' "ffff" 0 1 -- > Right 65535
-- > parseHex' "fffg" 0 1 -- > Left (Err {location = 4, reason = "Invalid character 'g'"})

parseHex' :: String -> Integer -> Int -> Either ParseError Integer
parseHex' []      val _   = return val
parseHex' (c:cs)  val idx = do d <- parseHexDigit c idx
	                       parseHex' cs ((val * 16) + d) (idx + 1)

toString :: Integer -> ParseMonad String
toString n = return $ show n

{-
> do { n <- parseHex "123"; toString n } 
Right "291"
> do { n <- parseHex "123"; toString n } `catchError` printError
Right "291"

-- 例外の場合 catchError によりエラーメッセージを編集する。
> do { n <- parseHex "123g"; toString n } 
Left (Err {location = 4, reason = "Invalid character 'g'"})

> do { n <- parseHex "123g"; toString n } `catchError` printError
Right "At index 4:Invalid character 'g'"
-}
convert :: String -> String
convert s = let (Right str) = do { n <- parseHex s; toString n } `catchError` printError
            in str

--  (Err {location = 4, reason = "Invalid character 'g'"}) == > "At index 4:Invalid character 'g'"
printError :: Monad m => ParseError -> m String
printError e = return $ "At index " ++ (show (location e)) ++ ":" ++ (reason e)

main :: IO ()
main = do args <- getArgs
          mapM_ (putStrLn . convert) args

例外を定義してみます。

data TestError  = TError Integer | Default String

instance Show TestError where
  show (TError n) = case n of
                      0 -> "Error 0"
                      1 -> "Error 2"
                      _ -> "Error Other"

  show (Default s) = "Err:Default " ++ s

instance Error TestError where
     noMsg    = Default "An error has occurred"
     strMsg s = Default s



{-
>  (throwError $ noMsg ):: Either TestError String
-- > Left Err:Default An error has occurred

>  (throwError $ strMsg "Hello ERROR!"):: Either TestError String
-- > Left Err:Default Hello ERROR!

>  (throwError $ TError 0):: Either TestError String
-- > Left Error 0

>  (throwError $ TError 1):: Either TestError String
-- > Left Error 2

>  (throwError $ TError 3):: Either TestError String
-- > Left Error Other

>  (return "OK"):: Either TestError String
-- > Right "OK"
-}

>  ((throwError $ strMsg "Hello ERROR!"):: Either TestError String) `catchError` (\x->Right $ show x)
-- > Right "Err:Default Hello ERROR!"

>  ((return "OK"):: Either TestError String) `catchError` (\x->Right $ show x)
-- > Right "OK"

do { action1; action2; action3 } `catchError` handler 

handler およびその do ブロックは 同じ返り値型をもたなければならない。