Freeモナド実用の旅(5): MonadPlus for Free

Control.MonadPlus.Freeはいなくなりました

えにっきをみてください

freeの新バージョンにControl.MonadPlus.Freeなるものがあったのでさっそく使ってみた。MonadPlus版Freeのコンストラクタは、Pure、Freeに加えて新たにPlusが加わっており、任意のFunctorからMonadPlusなモナドを生成することができる。

以下は、Freeモナドによって錬成されたパーサコンビネータの例。

import Control.Monad
import Control.MonadPlus.Free
import Control.Applicative
import Data.Char

data ParseStep a = ParseStep (Maybe Char -> Maybe a)

instance Functor ParseStep where
    fmap f (ParseStep g) = ParseStep (fmap f . g)

type Parser = Free ParseStep

runParser :: Parser a -> String -> Maybe a
runParser (Pure a) "" = Just a
runParser (Pure _) _ = Nothing
runParser (Free (ParseStep f)) str = case str of
    []     -> f Nothing  >>= flip runParser []
    (x:xs) -> f (Just x) >>= flip runParser xs
runParser (Plus xs) str = msum $ map (flip runParser str) xs -- ここがポイント！

anyChar :: Parser Char
anyChar = liftF (ParseStep id)

satisfy :: (Char -> Bool) -> Parser Char
satisfy f = do
    ch <- anyChar
    if f ch then pure ch else empty

char :: Char -> Parser Char
char ch = satisfy (==ch)

string :: String -> Parser String
string str = mapM char str

digit :: Parser Int
digit = digitToInt <$> satisfy isDigit

natural :: Parser Int
natural = foldl ((+) . (*10)) 0 <$> some digit

parens :: Parser a -> Parser a
parens p = char '(' *> p <* char ')'

chainl :: Parser a -> Parser (a -> a -> a) -> Parser a
chainl p op = p >>= rest where
    rest x = (op <*> pure x <*> p >>= rest) <|> return x

spaces :: Parser a -> Parser a
spaces p = many (char ' ') *> p <* many (char ' ')

fact :: Parser Int
fact = parens expr <|> natural

term :: Parser Int
term = chainl fact $ spaces
    $ char '*' *> return (*)
    <|> char '/' *> return div

expr :: Parser Int
expr = chainl term $ spaces
    $ char '+' *> return (+)
    <|> char '-' *> return (-)

main = do
    let ev = runParser expr
    print $ ev "42"                 -- Just 42
    print $ ev "1 + 1"              -- Just 2
    print $ ev "1 - (2 - 3)"        -- Just 2
    print $ ev "(1 - 2) - 3"        -- Just (-4)
    print $ ev "1 - 2 - 3"        -- Just (-4)
    print $ ev "2 * (3 + 5)"        -- Just 16
    print $ ev "(5 * 6 - 10) / 4"   -- Just 5
    print $ ev "1 + "               -- Nothing

やっぱりFreeモナドはすごい。