継続モナドの使い道 早期リターン

引数をチェックして、問題があれば Left に包んだエラーメッセージに、問題がなければ Right に包んだ計算結果に評価される関数を考えてみよう。
純粋な関数でもロジックを表現することは可能だが、if文のネストが深くなればなるほど地獄である。手続き型言語であれば早期リターンで書きたいところだが、関数型言語ではどうするのか。

checkName :: String -> String -> Either String String
checkName fstname famname =
  if ( length fstname == 0 )
  then Left "error: fstname is empty"
  else
    if not (isValidFirstName fstname)
    then Left "error: fstname is invalid"
    else
      if ( length famname == 0 )
      then Left "error: famname is empty"
      else
        if not (isValidFamilyName famname)
        then Left "error: famname is invalid"
        else Right $ fstname ++ " " ++ famname
  where
    isValidFirstName ca = (all isLower ca)
                          && ( 4 <= length ca && length ca <= 10)
    isValidFamilyName ca = (all isUpper ca)
                           && ( 2 <= length ca && length ca <= 8)

方法1. Eitherモナドを使う

※某所で指摘を受けたので追記。
Either モナド自体の性質を利用すれば、無尽蔵にネストが深くなっていく状況は避けることができる。場合によってはこれで十分だろう。ただ、より早期リターン風に表現したいときどうしたらよいか?

checkNameEM :: String -> String -> Either String String
checkNameEM fstname famname = do
  -- fstname 単体でチェック
  fstname' <- if ( length fstname == 0 )
              then Left "error: fstname is empty"
              else
                if not (isValidFirstName fstname)
                then Left "error: fstname is invalid"
                else Right fstname

  -- famname 単体でチェック
  famname' <- if ( length famname == 0 )
              then Left "error: famname is empty"
              else
                if not (isValidFamilyName famname)
                then Left "error: famname is invalid"
                else Right famname

  -- fstname' famname' の両方が Right の時だけ関数が評価される
  return $ fstname' ++ famname'
  where
    isValidFirstName ca = (all isLower ca)
                          && ( 4 <= length ca && length ca <= 10)
    isValidFamilyName ca = (all isUpper ca)
                           && ( 2 <= length ca && length ca <= 8)

ついでにApplicativeスタイルでの記述も載せておく。

checkNameEA :: String -> String -> Either String String
checkNameEA fstname famname = do
  -- fstname 単体でチェックした結果をEither(Left or Right)で包む
  let fstname' = if ( length fstname == 0 )
                 then Left "error: fstname is empty"
                 else
                   if not (isValidFirstName fstname)
                   then Left "error: fstname is invalid"
                   else Right fstname

  -- famname 単体でチェックした結果をEither(Left or Right)で包む
  let famname' = if ( length famname == 0 )
                 then Left "error: famname is empty"
                 else
                   if not (isValidFamilyName famname)
                   then Left "error: famname is invalid"
                   else Right famname

  -- Applicativeスタイル
  -- fstname' famname' の両方が Right の時だけ関数が評価される
  (\fst fam -> fst ++ " " ++ fam) <$> fstname' <*> famname'
  where
    isValidFirstName ca = (all isLower ca)
                          && ( 4 <= length ca && length ca <= 10)
    isValidFamilyName ca = (all isUpper ca)
                           && ( 2 <= length ca && length ca <= 8)

方法2. 継続モナドを使う

そこで継続モナド登場。純粋関数内で、早期リターンのような記述が可能となる。

checkNameC :: String -> String -> Either String String
checkNameC fstname famname = (`runCont` id) $ callCC $ \exit -> do
  when ( length fstname == 0 )
    $ exit $ Left "error: fstname is empty"

  when ( not (isValidFirstName fstname))
    $ exit $ Left "error: fstname is invalid"

  when ( length famname == 0 )
    $ exit $ Left "error: famname is empty"

  when ( not (isValidFamilyName famname))
    $ exit $ Left "error: famname is invalid"

  return $ Right $ fstname ++ " " ++ famname
  where
    isValidFirstName ca = (all isLower ca)
                          && ( 4 <= length ca && length ca <= 10)
    isValidFamilyName ca = (all isUpper ca)
                           && ( 2 <= length ca && length ca <= 8)

全部のせておく。

import Data.Char(isLower,isUpper)
import Control.Monad.Cont


checkName :: String -> String -> Either String String
checkName fstname famname =
  if ( length fstname == 0 )
  then Left "error: fstname is empty"
  else
    if not (isValidFirstName fstname)
    then Left "error: fstname is invalid"
    else
      if ( length famname == 0 )
      then Left "error: famname is empty"
      else
        if not (isValidFamilyName famname)
        then Left "error: famname is invalid"
        else Right $ fstname ++ " " ++ famname
  where
    isValidFirstName ca = (all isLower ca)
                          && ( 4 <= length ca && length ca <= 10)
    isValidFamilyName ca = (all isUpper ca)
                           && ( 2 <= length ca && length ca <= 8)



checkNameEM :: String -> String -> Either String String
checkNameEM fstname famname = do
  -- fstname 単体でチェック
  fstname' <- if ( length fstname == 0 )
              then Left "error: fstname is empty"
              else
                if not (isValidFirstName fstname)
                then Left "error: fstname is invalid"
                else Right fstname

  -- famname 単体でチェック
  famname' <- if ( length famname == 0 )
              then Left "error: famname is empty"
              else
                if not (isValidFamilyName famname)
                then Left "error: famname is invalid"
                else Right famname

  -- fstname' famname' の両方が Right の時だけ関数が評価される
  return $ fstname' ++ famname'
  where
    isValidFirstName ca = (all isLower ca)
                          && ( 4 <= length ca && length ca <= 10)
    isValidFamilyName ca = (all isUpper ca)
                           && ( 2 <= length ca && length ca <= 8)



checkNameEA :: String -> String -> Either String String
checkNameEA fstname famname = do
  -- fstname 単体でチェックした結果をEither(Left or Right)で包む
  let fstname' = if ( length fstname == 0 )
                 then Left "error: fstname is empty"
                 else
                   if not (isValidFirstName fstname)
                   then Left "error: fstname is invalid"
                   else Right fstname

  -- famname 単体でチェックした結果をEither(Left or Right)で包む
  let famname' = if ( length famname == 0 )
                 then Left "error: famname is empty"
                 else
                   if not (isValidFamilyName famname)
                   then Left "error: famname is invalid"
                   else Right famname

  -- Applicativeスタイル
  -- fstname' famname' の両方が Right の時だけ関数が評価される
  (\fst fam -> fst ++ " " ++ fam) <$> fstname' <*> famname'
  where
    isValidFirstName ca = (all isLower ca)
                          && ( 4 <= length ca && length ca <= 10)
    isValidFamilyName ca = (all isUpper ca)
                           && ( 2 <= length ca && length ca <= 8)



checkNameC :: String -> String -> Either String String
checkNameC fstname famname = (`runCont` id) $ callCC $ \exit -> do
  when ( length fstname == 0 )
    $ exit $ Left "error: fstname is empty"

  when ( not (isValidFirstName fstname))
    $ exit $ Left "error: fstname is invalid"

  when ( length famname == 0 )
    $ exit $ Left "error: famname is empty"

  when ( not (isValidFamilyName famname))
    $ exit $ Left "error: famname is invalid"

  return $ Right $ fstname ++ " " ++ famname
  where
    isValidFirstName ca = (all isLower ca)
                          && ( 4 <= length ca && length ca <= 10)
    isValidFamilyName ca = (all isUpper ca)
                           && ( 2 <= length ca && length ca <= 8)