Implementing functional languages を頑張って読む.6日目

# 6日目

ひたすらパーサの実装をする

## 33ページから

```hs
pThen3 :: (a -> b -> c -> d) -> Parser a -> Parser b -> Parser c -> Parser d
pThen3 combine p1 p2 p3 tokens
    = [(combine v1 v2 v3, tokens3) | (v1, tokens1) <- p1 tokens, (v2, tokens2) <- p2 tokens1, (v3, tokens3) <- p3 tokens2]

pThen4 :: (a -> b -> c -> d -> e) -> Parser a -> Parser b -> Parser c -> Parser d -> Parser e
pThen4 combine p1 p2 p3 p4 tokens
    = [(combine v1 v2 v3 v4, tokens4) | (v1, tokens1) <- p1 tokens, (v2, tokens2) <- p2 tokens1, (v3, tokens3) <- p3 tokens2, (v4, tokens4) <- p4 tokens3]

pZeroOrMore :: Parser a -> Parser [a]
pZeroOrMore p = (pOneOrMore p) `pAlt` (pEmpty [])

pEmpty :: a -> Parser a
pEmpty s toks = [(s, toks)]

pOneOrMore :: Parser a -> Parser [a]
pOneOrMore p = (take 1) . (pThen (:) p (pZeroOrMore p))

pApply :: Parser a -> (a -> b) -> Parser b
pApply a f toks = [(f b, tokens) | (b, tokens) <- a toks]

pOneOrMoreWithSep :: Parser a -> Parser b -> Parser [a]
pOneOrMoreWithSep a b = pThen (:) a (pThen (\_ x -> x) b (pOneOrMoreWithSep a b)) `pAlt` (pEmpty [])

pSat :: (String -> Bool) -> Parser String
pSat pd = pSatpred
    where   pSatpred ((n, tok):toks) = if pd tok then [(tok, toks)] else []
            pSatpred [] = []

pProgram :: Parser CoreProgram
pProgram = pOneOrMoreWithSep pSc (pLit ";")

pSc :: Parser CoreScDefn
pSc = pThen4 mk_sc pVar (pZeroOrMore pVar) (pLit "=") pExpr
    where mk_sc name arg _ expr = (name, arg, expr)

pExpr :: Parser CoreExpr
pExpr =     pThen mk_ap pExpr pAexpr
    `pAlt`  pThen3 mk_binop pExpr pBinop pExpr
    `pAlt`  pThen4 mk_let (pLit "let") pDefns (pLit "=") pExpr
    `pAlt`  pThen4 mk_letrec (pLit "letrec") pDefns (pLit "=") pExpr
    `pAlt`  pThen4 mk_case (pLit "case") pExpr (pLit "of") pAlts
    `pAlt`  pThen4 mk_lam (pLit "\\") (pOneOrMore pVar) (pLit ".") pExpr
    `pAlt`  pAexpr
    where 

pAexpr :: Parser CoreExpr
pAexpr =    pVar
    `pAlt`  pNum
    `pAlt`  pThen mk_pack2 (pThen4 mk_pack (pThen (:) (pLit "Pack") (pLit "{")) pNum (pLit ",") pNum) (pLit "}")
    `pAlt`  pThen3 mk_pexpr (pLit "(") pExpr (pLit ")")
    where

pDefns :: Parser [(Name, Expr Name)]
pDefns = pOneOrMoreWithSep pDefn (pLit ";")

pDefn :: Parser (Name, Expr Name)
pDefn = pThen3 mk_defn pVar (pLit "=") pExpr
        where mk_defn

pAlts :: Parser [CoreAlt]
pAlts = pOneOrMoreWithSep pAlt (pLit ";")

pAlt :: Parser CoreAlt
pAlt = pThen4 mk_alt (pThen3 mk_tag (pLit "<") pNum (pLit ">")) (pZeroOrMore pVar) (pLit "->") pExpr
        where

pBinop :: Parser String
pBinop = pArithop `pAlt` pRelop `pAlt` pBoolop

pArithop :: Parser String
pArithop = (pLit "+") `pAlt` (pLit "-") `pAlt` (pLit "*") `pAlt` (pLit "//")

pRelop :: Parser String
pRelop = (pLit "<") `pAlt` (pLit "<=") `pAlt` (pLit "==") `pAlt` (pLit "~=") `pAlt` (pLit ">=") `pAlt` (pLit ">")

pBoolop :: Parser String
pBoolop = (pLit "&") `pAlt` (pLit "|")

syntax :: [Token] -> CoreProgram
syntax = take_first_parse . pProgram
    where
    take_first_parse ((prog, []) : others) = prog
    take_first_parse (parse : others) = take_first_parse others
    take_first_parse other = error "Syntax error"

parse :: String -> CoreProgram
parse = syntax . clex

main :: IO ()
--main = putStrLn $ iDisplay $ pprExpr (ELet nonRecursive [("att", ENum 2)] (EAp (EAp (EVar "+") (EVar "att")) (EVar "1")))
main = putStrLn( show (pOneOrMore (pLit "x") (replicate 3 (1, "x"))))
```

**38ページのExercise 1.20をやりかけで終わった**