LoginSignup
5
2

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?

More than 5 years have passed since last update.

@7shi

【解答例】Haskell 構文解析 超入門

Last updated at Posted at 2015-07-31

Haskell 構文解析 超入門の解答例です。

Stateモナド

【問1】モナドなしのまとめのコードをStateモナドを使って書き換えてください。

import Control.Exception
import Control.Monad.State
import Data.Char

parseTest p s = do
    print $ evalState p s
    `catch` \(SomeException e) ->
        putStr $ show e

anyChar = state $ anyChar where
    anyChar (x:xs) = (x, xs)

satisfy :: (Char -> Bool) -> State String Char
satisfy f = state $ satisfy where
    satisfy (x:xs) | f x = (x, xs)

char c = satisfy (== c)
digit  = satisfy isDigit
letter = satisfy isLetter

test1 = do
    x1 <- anyChar
    x2 <- anyChar
    return [x1, x2]

test2 = do
    x1 <- test1
    x2 <- anyChar
    return $ x1 ++ [x2]

test3 = do
    x1 <- letter
    x2 <- digit
    x3 <- digit
    return [x1, x2, x3]

main = do
    parseTest anyChar "abc"
    parseTest test1   "abc"
    parseTest test2   "abc"
    parseTest test2   "12"      -- NG
    parseTest test2   "123"
    parseTest (char 'a') "abc"
    parseTest (char 'a') "123"  -- NG
    parseTest digit  "abc"      -- NG
    parseTest digit  "123"
    parseTest letter "abc"
    parseTest letter "123"      -- NG
    parseTest test3  "abc"      -- NG
    parseTest test3  "123"      -- NG
    parseTest test3  "a23"
    parseTest test3  "a234"
実行結果
'a'
"ab"
"abc"
Main.hs:11:5-28: Non-exhaustive patterns in function anyChar
"123"
'a'
Main.hs:15:5-34: Non-exhaustive patterns in function satisfy
Main.hs:15:5-34: Non-exhaustive patterns in function satisfy
'1'
'a'
Main.hs:15:5-34: Non-exhaustive patterns in function satisfy
Main.hs:15:5-34: Non-exhaustive patterns in function satisfy
Main.hs:15:5-34: Non-exhaustive patterns in function satisfy
"a23"
"a23"

※ satisfyに型注釈を付けないとエラーになります。

Maybeモナド

【問2】モナドなしのまとめのコードをMaybeモナドを使って書き換えてください。

import Data.Char

parseTest p s = case p s of
    Just (r, _) -> print r
    n           -> print n

anyChar (x:xs) = Just (x, xs)
anyChar _      = Nothing

satisfy f (x:xs) | f x = Just (x, xs)
satisfy _ _            = Nothing

char c = satisfy (== c)
digit  = satisfy isDigit
letter = satisfy isLetter

test1 xs0 = do
    (x1, xs1) <- anyChar xs0
    (x2, xs2) <- anyChar xs1
    return ([x1, x2], xs2)

test2 xs0 = do
    (x1, xs1) <- test1   xs0
    (x2, xs2) <- anyChar xs1
    return (x1 ++ [x2], xs2)

test3 xs0 = do
    (x1, xs1) <- letter xs0
    (x2, xs2) <- digit  xs1
    (x3, xs3) <- digit  xs2
    return ([x1, x2, x3], xs3)

main = do
    parseTest anyChar "abc"
    parseTest test1   "abc"
    parseTest test2   "abc"
    parseTest test2   "12"      -- NG
    parseTest test2   "123"
    parseTest (char 'a') "abc"
    parseTest (char 'a') "123"  -- NG
    parseTest digit  "abc"      -- NG
    parseTest digit  "123"
    parseTest letter "abc"
    parseTest letter "123"      -- NG
    parseTest test3  "abc"      -- NG
    parseTest test3  "123"      -- NG
    parseTest test3  "a23"
    parseTest test3  "a234"
実行結果
'a'
"ab"
"abc"
Nothing
"123"
'a'
Nothing
Nothing
'1'
'a'
Nothing
Nothing
Nothing
"a23"
"a23"

many

【問3】指定したパーサを0回以上適用して返すコンビネータmanyを実装してください。

import Control.Applicative ((<$>), (<*>))
import Control.Monad
import Control.Monad.State
import Data.Char

parseTest p s = case evalStateT p s of
    Right r -> print r
    Left  e -> putStrLn $ "[" ++ show s ++ "] " ++ e

anyChar = StateT $ anyChar where
    anyChar (x:xs) = Right (x, xs)
    anyChar _      = Left "too short"

satisfy f = StateT $ satisfy where
    satisfy (x:xs) | not $ f x = Left $ ": " ++ show x
    satisfy    xs              = runStateT anyChar xs

(StateT a) <|> (StateT b) = StateT $ \s ->
    (a s)  <|> (b s) where
    Left a <|> Left b = Left $ b ++ a
    Left _ <|> b      = b
    a      <|> _      = a

left = lift . Left

char c = satisfy (== c)   <|> left ("not char " ++ show c)
digit  = satisfy isDigit  <|> left "not digit"
letter = satisfy isLetter <|> left "not letter"

many p = ((:) <$> p <*> many p) <|> return []

test7 = many letter
test8 = many (letter <|> digit)

main = do
    parseTest test7 "abc123"
    parseTest test7 "123abc"
    parseTest test8 "abc123"
    parseTest test8 "123abc"
実行結果
"abc"
""
"abc123"
"123abc"

エラーチェック

【問4】問3の解答の自前実装では失敗時に返されるLeftに状態が含まれず、1つでも成功していたかが判断できません。leftを次のように修正することで状態を返して、Parsecと同じようにエラーをチェックしてください。

import Control.Applicative ((<$>), (<*>))
import Control.Monad
import Control.Monad.State
import Data.Char

parseTest p s = case evalStateT p s of
    Right r     -> print r
    Left (e, _) -> putStrLn $ "[" ++ show s ++ "] " ++ e

anyChar = StateT $ anyChar where
    anyChar (x:xs) = Right (x, xs)
    anyChar    xs  = Left ("too short", xs)

satisfy f = StateT $ satisfy where
    satisfy (x:xs) | not $ f x = Left (": " ++ show x, x:xs)
    satisfy    xs              = runStateT anyChar xs

(StateT a) <|> (StateT b) = StateT f where
    f s0 =   (a  s0) <|> (b  s0) where
        Left (a, s1) <|> _ | s0 /= s1 = Left (     a, s1)
        Left (a, _ ) <|> Left (b, s2) = Left (b ++ a, s2)
        Left _       <|> b            = b
        a            <|> _            = a

left e = StateT $ \s -> Left (e, s)

char c = satisfy (== c)   <|> left ("not char " ++ show c)
digit  = satisfy isDigit  <|> left "not digit"
letter = satisfy isLetter <|> left "not letter"

many p = ((:) <$> p <*> many p) <|> return []

test9 = sequence [char 'a', char 'b']
    <|> sequence [char 'a', char 'c']

main = do
    parseTest test9 "ab"
    parseTest test9 "ac"
実行結果
"ab"
["ac"] not char 'b': 'c'

バックトラック

【問5】問4の解答の自前実装にtryとstringを実装してください。

import Control.Applicative ((<$>), (<*>))
import Control.Monad
import Control.Monad.State
import Data.Char

parseTest p s = case evalStateT p s of
    Right r     -> print r
    Left (e, _) -> putStrLn $ "[" ++ show s ++ "] " ++ e

anyChar = StateT $ anyChar where
    anyChar (x:xs) = Right (x, xs)
    anyChar    xs  = Left ("too short", xs)

satisfy f = StateT $ satisfy where
    satisfy (x:xs) | not $ f x = Left (": " ++ show x, x:xs)
    satisfy    xs              = runStateT anyChar xs

(StateT a) <|> (StateT b) = StateT f where
    f s0 =   (a  s0) <|> (b  s0) where
        Left (a, s1) <|> _ | s0 /= s1 = Left (     a, s1)
        Left (a, _ ) <|> Left (b, s2) = Left (b ++ a, s2)
        Left _       <|> b            = b
        a            <|> _            = a

try (StateT p) = StateT $ \s -> case p s of
    Left (e, _) -> Left (e, s)
    r           -> r 

left e = StateT $ \s -> Left (e, s)

char c = satisfy (== c)   <|> left ("not char " ++ show c)
digit  = satisfy isDigit  <|> left "not digit"
letter = satisfy isLetter <|> left "not letter"

string s = sequence [char x | x <- s]

many p = ((:) <$> p <*> many p) <|> return []

test10 = try (sequence [char 'a', char 'b'])
         <|>  sequence [char 'a', char 'c']
test11 =      string "ab"  <|> string "ac"
test12 = try (string "ab") <|> string "ac"

main = do
    parseTest test10 "ab"
    parseTest test10 "ac"
    parseTest test11 "ab"
    parseTest test11 "ac"
    parseTest test12 "ab"
    parseTest test12 "ac"
実行結果
"ab"
"ac"
"ab"
["ac"] not char 'b': 'c'
"ab"
"ac"

括弧

【問6】項の下位に因子（factor）という層を追加して、括弧をサポートしてください。<*を使ってください。

import Text.Parsec
import Control.Applicative ((<$>), (<*>), (<*), (*>))

eval m fs = foldl (\x f -> f x) <$> m <*> fs
apply f m = flip f <$> m

-- expr = term, {("+", term) | ("-", term)}
expr = eval term $ many $
        char '+' *> apply (+) term
    <|> char '-' *> apply (-) term

-- term = factor, {("*", factor) | ("/", factor)}
term = eval factor $ many $
        char '*' *> apply (*) factor
    <|> char '/' *> apply div factor

-- factor = ("(", expr, ")") | number
factor = char '(' *> expr <* char ')' <|> number

number = read <$> many1 digit

main = do
    parseTest expr "(2+3)*4"
実行結果
20

スペース

【問7】スペースを無視してください。

factorの修正だけで対応できます。

import Text.Parsec
import Control.Applicative ((<$>), (<*>), (<*), (*>))

eval m fs = foldl (\x f -> f x) <$> m <*> fs
apply f m = flip f <$> m

-- expr = term, {("+", term) | ("-", term)}
expr = eval term $ many $
        char '+' *> apply (+) term
    <|> char '-' *> apply (-) term

-- term = factor, {("*", factor) | ("/", factor)}
term = eval factor $ many $
        char '*' *> apply (*) factor
    <|> char '/' *> apply div factor

-- factor = [spaces], ("(", expr, ")") | number, [spaces]
factor = spaces
      *> (char '(' *> expr <* char ')' <|> number)
     <*  spaces

number = read <$> many1 digit

main = do
    parseTest expr "1 + 2"
    parseTest expr "123"
    parseTest expr "1 + 2 + 3"
    parseTest expr "1 - 2 - 3"
    parseTest expr "1 - 2 + 3"
    parseTest expr "2 * 3 + 4"
    parseTest expr "2 + 3 * 4"
    parseTest expr "100 / 10 / 2"
    parseTest expr "( 2 + 3 ) * 4"
実行結果
3
123
6
-4
2
10
14
5
20

自前実装

【問8】問7の解答を、Parsecを使わずに問5の解答の自前実装に足りない関数を補って動かしてください。ただし次のように演算子の優先順位を指定する必要があります。

import Control.Applicative ((<$>), (<*>), (<*), (*>))
import Control.Monad
import Control.Monad.State
import Data.Char

parseTest p s = case evalStateT p s of
    Right r     -> print r
    Left (e, _) -> putStrLn $ "[" ++ show s ++ "] " ++ e

anyChar = StateT $ anyChar where
    anyChar (x:xs) = Right (x, xs)
    anyChar    xs  = Left ("too short", xs)

satisfy f = StateT $ satisfy where
    satisfy (x:xs) | not $ f x = Left (": " ++ show x, x:xs)
    satisfy    xs              = runStateT anyChar xs

infixr 1 <|>
(StateT a) <|> (StateT b) = StateT f where
    f s0 =   (a  s0) <|> (b  s0) where
        Left (a, s1) <|> _ | s0 /= s1 = Left (     a, s1)
        Left (a, _ ) <|> Left (b, s2) = Left (b ++ a, s2)
        Left _       <|> b            = b
        a            <|> _            = a

try (StateT p) = StateT $ \s -> case p s of
    Left (e, _) -> Left (e, s)
    r           -> r 

left e = StateT $ \s -> Left (e, s)

char c = satisfy (== c)   <|> left ("not char " ++ show c)
digit  = satisfy isDigit  <|> left "not digit"
letter = satisfy isLetter <|> left "not letter"
space  = satisfy isSpace  <|> left "not space"
spaces = skipMany space

string s = sequence [char x | x <- s]

many p = many1 p <|> return []
many1 p = (:) <$> p <*> many p
skipMany p = many p *> return ()

eval m fs = foldl (\x f -> f x) <$> m <*> fs
apply f m = flip f <$> m

-- expr = term, {("+", term) | ("-", term)}
expr = eval term $ many $
        char '+' *> apply (+) term
    <|> char '-' *> apply (-) term

-- term = factor, {("*", factor) | ("/", factor)}
term = eval factor $ many $
        char '*' *> apply (*) factor
    <|> char '/' *> apply div factor

-- factor = [spaces], ("(", expr, ")") | number, [spaces]
factor = spaces
      *> (char '(' *> expr <* char ')' <|> number)
     <*  spaces

number = read <$> many1 digit

main = do
    parseTest expr "1 + 2"
    parseTest expr "123"
    parseTest expr "1 + 2 + 3"
    parseTest expr "1 - 2 - 3"
    parseTest expr "1 - 2 + 3"
    parseTest expr "2 * 3 + 4"
    parseTest expr "2 + 3 * 4"
    parseTest expr "100 / 10 / 2"
    parseTest expr "( 2 + 3 ) * 4"
実行結果
3
123
6
-4
2
10
14
5
20
5
2
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
5
2

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?