参考URL
ソース
エラー型定義
エラーが発生したときに原因をわかりやすくするため、
エラー型を定義します。
data LispError = NumArgs Integer [LispVal]
| TypeMismatch String LispVal
| Parser ParseError
| BadSpecialForm String LispVal
| NotFunction String String
| UnboundVar String String
| Default String
また、LispErrorをShowのインスタンスにして、
表示(文字列化)可能にします。
showError :: LispError -> String
showError (UnboundVar message varname) = message ++ ": " ++ varname
showError (BadSpecialForm message form) = message ++ ": " ++ show form
showError (NotFunction message func) = message ++ ": " ++ show func
showError (NumArgs expected found) = "Expected " ++ show expected
++ " args; found values " ++ unwordsList found
showError (TypeMismatch expected found) = "Invalid type: expected " ++ expected
++ ", found " ++ show found
showError (Parser parseErr) = "Parse error at " ++ show parseErr
instance Show LispError where show = showError
また、LispErrorをErrorのインスタンスにします。
Errorのインスタンスにするとエラーを処理する組み込み関数が
使えるようになります。
instance Error LispError where
noMsg = Default "An error has occurred"
strMsg = Default
strMsgは文字列をError型に変えるために定義されているようです。
(noMsg,strMsgを実装する理由についてはイマイチ理解できていません。)
次に、利便性のためEitherのLeftにLispErrorを
固定させた型を定義します。
type ThrowsError = Either LispError
実際に使用する際はRightの型を指定して
ThrowsError String
ThrowsErrro LispVal
のように使用します。
エラーを文字列に変えるための関数を定義します。
trapError action = catchError action (return . show)
参考URLの内容では型が書かれていませんが、この型は
ThrowsError String -> ThrowsError String
になります。
catchErrorはactionがエラー(Left値)なら
Leftの値に、渡された関数(return . show)を適用し、
その結果(String)をThrowsErrorに包んで返します。
Right値ならRightの値(String)をそのまま
ThrowsErrorに包んで返却します。
ThrowsErrorのRight値を取り出すための関数も定義します。
extractValue :: ThrowsError a -> a
extractValue (Right val) = val
Left値が入った状態で呼ばれた際は意図的にエラーにするために
Rightのパターンしか記載していないようです。
続いてreadExprをThrowsErrorを返すように修正します。
ThrowsErrorのRight型はLispValです。
readExpr :: String -> ThrowsError LispVal
readExpr input = case parse parseExpr "lisp" input of
Left err -> throwError $ Parser err
Right val -> return val
parse関数の結果がRight値だった場合は結果を
ThrowsErrorのRight値に入れて返します。
Left値の場合はthrowError関数を使って、
ThrowErrorのLeft値にParserエラーとして格納して
返却します。
次にevalを修正します。
eval :: LispVal -> ThrowsError LispVal
eval val@(String _) = return val
eval val@(Number _) = return val
eval val@(Bool _) = return val
eval (List [Atom "quote", val]) = return val
eval (List (Atom func : args)) = mapM eval args >>= apply func
eval badForm = throwError $ BadSpecialForm "Unrecognized special form" badForm
String,Number,Boolはそのままreturnで
ThrowsErrorに包んでいるだけです。
quoteもquoteされた値をreturnしているだけです。
一番下のbadFormに来るのはどのパターンにも当てはまらなかった場合です。
thorowErrorを使ってLeft値にBadSpecialFormエラーを入れています。
evalに先頭がquote以外のAtomであるListが渡された場合は
少し複雑になります。
まずListの先頭以外をevalで評価します。
argsの各要素に対してevalをする際、
mapではなくmapMが使われています。
もし、
map eval args
とした場合、戻り値の型は[ThrowsError LispVal]になります。
しかし、次のapply関数に渡すためにThrowsError [LispVal]型の結果
が求められます。
そのため
mapM eval args
を行っています。
イメージとしてはmapとmapMの差は以下になります。
map eval [LispVal]
=> [ThrowsError LispVal,ThrowsError LispVal,ThrowsError LispVal]
mapM eval [LispVal]
=> ThrowsError [LispVal]
apply関数も修正します。
lookupに失敗した場合はNotFunctionエラーを返すようになります。
成功した場合の処理はそのままですが、これは
primitves側で変更しているためです。
apply :: String -> [LispVal] -> ThrowsError LispVal
apply func args = maybe (throwError $ NotFunction "Unrecognized primitive function args" func)
($ args)
(lookup func primitives)
primitivesも修正します。
変更点は戻り値の型だけで、実装はそのままです。
実装の変更はprimitiveから呼ばれるnumericBinop,unpackNumで
対応します。
primitives :: [(String, [LispVal] -> ThrowsError LispVal)]
numericBinopを修正します。
numericBinop :: (Integer -> Integer -> Integer) -> [LispVal] -> ThrowsError LispVal
numericBinop op singleVal@[_] = throwError $ NumArgs 2 singleVal
numericBinop op params = mapM unpackNum params >>= return . Number . foldl1 op
引数が要素一つのリストだった場合はNumArgsエラーを返しています。
それ以外の場合は、少し複雑ですが、まずparamsにunpackNumを
mapMで適用します。
unpackNumはThrowsError Integer型を返すように修正します。
unpackNum :: LispVal -> ThrowsError Integer
unpackNum (Number n) = return n
unpackNum (String n) = let parsed = reads n in
if null parsed
then throwError $ TypeMismatch "number" $ String n
else return $ fst $ parsed !! 0
unpackNum (List [n]) = unpackNum n
unpackNum notNum = throwError $ TypeMismatch "number" notNum
そのためnumericBinopの
mapM unpackNum params
はThrowsError [Integer]を返します。
この結果を
hs
return . Number . foldl1 op
に適用します。
順番に見ていくと、まずfold1 opにunpackNumした[Integer]が
渡されます。
結果opで順々に関数適用されて、結果のIntegerが返されます。
これにNumberコンストラクタを適用してLispVal型にします。
さらにreturnをかけることでThrowsError LispVal型にします。
numbericBinopはThrowsError LispVal型を返すと定義されているので
これで目的の型を返せるようになりました。
最後にmainを修正します。
main :: IO ()
main = do
args <- getArgs
evaled <- return $ liftM show $ readExpr (args !! 0) >>= eval
putStrLn $ extractValue $ trapError evaled
mainの実装もかなり複雑なので、少しずつみていきます。
まず、
evaled <- return $ liftM show $ readExpr (args !! 0) >>= eval
の箇所ですが、
readExpr (args !! 0) >>= eval
は、readExprで得たThrwosError LispValのLispValの部分を
evalに渡します。結果としてThrowsError LispValを得ます。
この結果にliftM showを適用します。
liftMはThrowsErrorの内部、今回はLispValに対し、
指定した関数を適用します。
そのため、liftM show $ ThrowsError LispValの結果は
ThrowsError Stringになります。
この結果に対してreturnを適用しています。
このreturnはmainの中で使われているので、IOに包まれることになります。
更に包まれた中身をevaled変数に入れています。
この結果evaled変数はThrowsError LispValが入ることになります。
次に、
putStrLn $ extractValue $ trapError evaled
の部分を見ていきます。
trapErrorはevaledにThrowsErrorのLeft値が入っている場合、
エラーを文字列に変えて戻します。Left値をRight値に移すような
感じです。
エラーでない場合はそのままの値を戻します。
その結果に対し、extractValueを適用すると、ThrowError Stringの
Stringの部分が取得できます。
その習得したStringに対し、putStrLn関数を適用することで、
これまでの処理結果を表示させています。