JavaScript版に対応させるHaskellでのParser実装

昨日のJavaScriptでの関数型パーザー( id:bellbind:20060529:1148843131 )を、きちんとする際、同等のHaskellコードと対応付けて説明を書こうと思った。

両方作るんだけど、型の問題とかあるので、先にHaskellでParserを実装してみた。

data PState result
    = PState
      { codeField :: String,
        posField :: Int,
        resultField :: result }
      deriving Show

data Parser result
    = Parser
      { parseMethod :: String -> Int -> Maybe (PState result) }

parserBind :: Parser a -> (a -> Parser b) -> Parser b
parserBind src dst
    = Parser { parseMethod = newParse }
    where
      newParse inCode inPos
          = let srcParse = parseMethod src in
            case (srcParse inCode inPos) of
              Nothing -> Nothing
              Just newState
                  -> let newCode = codeField newState in
                     let newPos = posField newState in
                     let newResult = resultField newState in
                     let dstParser = dst newResult in
                     let dstParse = parseMethod dstParser in
                     dstParse newCode newPos


parserNext :: Parser a -> Parser b -> Parser b
parserNext src dst
    = Parser { parseMethod = newParse }
    where
      newParse inCode inPos
          = let srcParse = parseMethod src in
            case (srcParse inCode inPos) of
              Nothing -> Nothing
              Just newState
                  -> let newCode = codeField newState in
                     let newPos = posField newState in
                     let newResult = resultField newState in
                     let dstParse = parseMethod dst in
                     dstParse newCode newPos

parserReturn :: a -> Parser a
parserReturn resultValue
    = Parser { parseMethod = newParse }
    where
      newParse inCode inPos
          = let resultState = PState
                              { codeField = inCode,
                                posField = inPos,
                                resultField = resultValue } in
            Just resultState

parserFail :: String -> Parser a
parserFail error
    = Parser { parseMethod = newParse }
    where
      newParse inCode inPos
          = Nothing

charParser :: Char -> Parser Char
charParser ch
    = Parser { parseMethod = newParse }
    where
      newParse inCode inPos
          = if (inPos < (length inCode)) && ((inCode !! inPos) == ch) then
                let newState = PState { codeField = inCode,
                                        posField = inPos + 1,
                                        resultField = ch} in
                Just newState
            else Nothing

manyParser :: Parser a -> Parser [a]
manyParser parser
    = Parser { parseMethod = newParse }
    where
      newParse inCode inPos
          = parseNext [] inCode inPos
      parseNext results inCode inPos
          = case (parseMethod parser) inCode inPos of
            Nothing
                -> Just (PState { codeField = inCode,
                                  posField = inPos,
                                  resultField = results})
            Just newState
                 -> let newResults = results ++ [(resultField newState)] in
                    let newCode = codeField newState in
                    let newPos = posField newState in
                    parseNext newResults newCode newPos

orElseParser :: Parser a -> Parser a -> Parser a
orElseParser parser1 parser2
    = Parser { parseMethod = newParse }
    where
      newParse inCode inPos
          = let parser1Parse = parseMethod parser1 in
            case (parser1Parse inCode inPos) of
              Just newState -> Just newState
              Nothing
                  -> let parser2Parse = parseMethod parser2 in
                     parser2Parse inCode inPos

instance Monad Parser where
    (>>=) src dst = parserBind src dst
    (>>) src dst = parserNext src dst
    return retVal = parserReturn retVal
    fail error = parserFail error

stringParser []
    = do return []
stringParser (ch:t)
    = do result <- charParser ch
         results <- stringParser t
         return (result:results)

abcOrDefParser
    = manyParser (orElseParser (stringParser "abc") (stringParser "def"))

parseCode parser code
    = (parseMethod parser) code 0

PStateはタプルを使えば簡単だけど、JavaScriptとの対応付けからレコード型にしてます。あとレコード型のメンバー名もStupid精神からメンバーアクセスとわかる名前にしてます。

このParserはMonadになっていて、これはきちんと動くコードです。ghciなどで読み込んで、

Main> parseCode abcOrDefParser "abcdefabcd"

などと打ちこんでやればいけます。

parseMethodの引数のあたりが少し変わってますが、なんとなく構造的には昨日のコードと似てるでしょう。