instance Functor Parserwhere fmap f (Parserparser) = Parser (\str -> first f <$> parser str)
PGSQL
第二个是 Applicative 实例。该实例的常见用例是在多个解析器中实现一个纯函数。
1 2 3 4 5 6 7 8 9
instance Applicative Parserwhere pure x = Parser (\str -> Right (x, str)) (Parser p1) <*> (Parser p2) = Parser $ \str -> do (f, rest) <- p1 str (x, rest') <- p2 rest pure (f x, rest')
PGSQL
(注意:我们还会实现一个 Monad 实例,这样我们才能使用符号)
第三个是 Alternative 实例。万一前面的解析器解析失败了,我们要能够提供一个备用的解析器。
1 2 3 4 5 6 7
instance Alternative Parser where empty = Parser (`throwErr` "Failed consuming input") (Parser p1) <|> (Parser p2) = Parser $ \pstr -> case p1 pstr of Right result -> Right result Left_ -> p2 pstr
COQ
第四个是 Monad 实例。这样我们就能链接解析器。
1 2 3 4 5 6 7 8
instance Monad Parser where (Parser p1) >>= f = Parser $ \str -> case p1 str of Left err -> Left err Right (rs, rest) -> case f rs of Parser parser -> parser rest
COQ
接下来,让我们定义一种的方式,用于运行解析器和防止失败的助手函数:
1 2 3 4 5 6 7 8 9 10
runParser :: String -> String -> Parser a -> Either ParseError (a, ParseString) runParser name str (Parser parser) = parser $ ParseString name (0,0) str
throwErr :: ParseString -> String -> Either ParseError a throwErr ps@(ParseString name (row,col) _) errMsg = Left $ ParseError ps $ unlines [ "*** " ++ name ++ ": " ++ errMsg , "* On row " ++ show row ++ ", column " ++ show col ++ "." ]
oneOf :: [Char] -> ParserChar oneOf chars = Parser $ \case ps@(ParseString name (row, col) str) -> case str of [] -> throwErr ps "Cannot read character of empty string" (c:cs) -> if c `elem` chars then Right (c, ParseString name (row, col+1) cs) else throwErr ps $ unlines ["Unexpected character " ++ [c], "Expecting one of: " ++ show chars]
PGSQL
optional 将会抛出异常,停止解析器。失败时它仅仅会返回 Nothing。
1 2 3 4 5 6
optional :: Parser a -> Parser (Maybe a) optional (Parserparser) = Parser $ \pstr -> caseparser pstr of Left _ -> Right (Nothing, pstr) Right (x, rest) -> Right (Just x, rest)
PGSQL
many 将会试着重复运行解析器,直到失败。当它完成的时候,会返回成功运行的解析器列表。many1 做的事情是一样的,但解析失败时它至少会抛出一次异常。
1 2 3 4 5 6 7
many :: Parser a -> Parser [a] many parser = go [] where go cs = (parser >>= \c -> go (c:cs)) <|> pure (reverse cs)
many1 :: Parser a -> Parser [a] many1 parser = (:) <$> parser <*> many parser
parseName :: ParserName parseName = do c <- oneOf ['a'..'z'] cs <- many $ oneOf $ ['a'..'z'] ++ "0123456789" ++ "_" pure (c:cs)
ELIXIR
整数是一系列数字,数字前面可能有负号 -:
1 2 3 4 5 6
parseInt :: Parser Atom parseInt = do sign <- optional $ char'-' num <- many1 $ oneOf "0123456789" let result = read $ maybe num (:num) sign of pure $ Int result
LIVECODESERVER
最后,我们会定义用来运行解析器的函数,返回值可能是一个 Expr 或者是一条错误信息。
1 2 3 4 5
runExprParser :: Name -> String -> Either String Expr runExprParser name str = case runParser name str (withSpaces parseExpr) of Left (ParseError _ errMsg) -> Left errMsg Right (result, _) -> Right result
基本思想很简单,我们会将 ATOM 转译成 JSSymbol 或者 JSInt,然后会将 LIST 转译成一个函数调用或者转译的特例。
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16
type TransError = String
translateToJS :: Expr -> Either TransError JSExpr translateToJS = \case ATOM (Symbol s) -> pure $ JSSymbol s ATOM (Int i) -> pure $ JSInt i LIST xs -> translateList xs
translateList :: [Expr] -> Either TransError JSExpr translateList = \case [] -> Left "translating empty list" ATOM (Symbol s):xs | Just f <- lookup s builtins -> f xs f:xs -> JSFunCall <$> translateToJS f <*> traverse translateToJS xs
vars -> Left$ unlines ["Syntax error: unexpected arguments for lambda." ,"expecting 2 arguments, the first is the list of vars and the second is the body of the lambda." ,"In expression: " ++ show (LIST$ ATOM (Symbol"lambda") : vars) ]
fromSymbol :: Expr -> EitherStringName fromSymbol (ATOM (Symbol s)) = Right s fromSymbol e = Left$ "cannot bind value to non symbol type: " ++ show e
ELIXIR
我们会将 let 转译成带有相关名字参数的函数定义,然后带上参数调用函数,因此会在这一作用域中引入变量:
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19
transLet :: [Expr] -> Either TransError JSExpr transLet = \case [LIST binds, body] -> do (vars, vals) <- letParams binds vars' <- traverse fromSymbol vars JSFunCall . JSLambda vars' <$> (JSReturn <$> translateToJS body) <*> traverse translateToJS vals where letParams :: [Expr] -> Either Error ([Expr],[Expr]) letParams = \case [] -> pure ([],[]) LIST [x,y] : rest -> ((x:) *** (y:)) <$> letParams rest x : _ -> Left ("Unexpected argument in let list in expression:\n" ++ printExpr x)
vars -> Left $ unlines ["Syntax error: unexpected arguments for let." ,"expecting 2 arguments, the first is the list of var/val pairs and the second is the let body." ,"In expression:\n" ++ printExpr (LIST $ ATOM (Symbol "let") : vars) ]
transBinOp :: Name -> Name -> [Expr] -> Either TransError JSExpr transBinOp f _ [] = Left $ "Syntax error: '" ++ f ++ "' expected at least 1 argument, got: 0" transBinOp _ _ [x] = translateToJS x transBinOp _ f list = foldl1 (JSBinOp f) <$> traverse translateToJS list