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

# 5日目

## 33ページ

Parserを一応関数ポインタの型として定義しておく.
pLitをParser型を使って書くとどうしてもクロージャみたいなことをしないといけない.
完全に困ったのでCで書くのは諦めてHaskellで書く.
関数型言語で関数型言語を実装するのは負けた気がするが読み進めるためには仕方ない.

33ページまでのソースをhaskellに写経しただけ.一応Exercisesもやった.
syntaxの定義がないのでコケる.

```hs
import Data.Char

data Expr a
    = EVar Name -- Variables
    | ENum Int -- Numbers
    | EConstr Int Int -- Constructor tag arity
    | EAp (Expr a) (Expr a) -- Applications
    | ELet -- Let(rec) expressions
        IsRec -- boolean with True = recursive,
        [(a, Expr a)] -- Definitions
        (Expr a) -- Body of let(rec)
    | ECase -- Case expression
        (Expr a) -- Expression to scrutinise
        [Alter a] -- Alternatives
    | ELam [a] (Expr a) -- Lambda abstractions

type CoreExpr = Expr Name

type Name = String
 
type IsRec = Bool
recursive, nonRecursive :: IsRec
recursive = True
nonRecursive = False

bindersOf :: [(a,b)] -> [a]
bindersOf defns = [name | (name, rhs) <- defns]

rhssOf :: [(a,b)] -> [b]
rhssOf defns = [rhs | (name, rhs) <- defns]

type Alter a = (Int, [a], Expr a)
type CoreAlt = Alter Name

isAtomicExpr :: Expr a -> Bool
isAtomicExpr (EVar v) = True
isAtomicExpr (ENum n) = True
isAtomicExpr e = False

type Program a = [ScDefn a]
type CoreProgram = Program Name

type ScDefn a = (Name, [a], Expr a)
type CoreScDefn = ScDefn Name

preludeDefs :: CoreProgram
preludeDefs
    = [ ("I", ["x"], EVar "x"),
        ("K", ["x","y"], EVar "x"),
        ("F",["x","y"], EVar "y"),
        ("S", ["x","y","z"], EAp (EAp (EVar "x") (EVar "z")) (EAp (EVar "y") (EVar "z"))),
        ("C", ["x","y","z"], EAp (EVar "x") (EAp (EVar "y") (EVar "z"))),
        ("B", ["x","y","z"], EAp (EAp (EVar "x") (EVar "z")) (EVar "y")), 
        ("W", ["x", "y"], EAp (EAp (EVar "x") (EVar "y")) (EVar "y")) ]

data Iseq = INil
            | IStr String
            | IAppend Iseq Iseq
            | IIndent Iseq
            | INewline        
iNil :: Iseq -- The empty iseq
iStr :: String -> Iseq -- Turn a string into an iseq
iNum :: Int -> Iseq
iAppend :: Iseq -> Iseq -> Iseq -- Append two iseqs
iNewline :: Iseq -- New line with indentation
iIndent :: Iseq -> Iseq -- Indent an iseq
iNil = INil
iAppend seq INil = seq
iAppend INil seq = seq
iAppend seq1 seq2 = IAppend seq1 seq2
iNum n = iStr (show n)
iIndent seq = IIndent seq
iNewline = INewline
iStr str = if elem '\n' str then (IStr (takeWhile (/= '\n') str)) `iAppend` iNewline `iAppend` (IStr (tail (dropWhile (/= '\n') str))) else IStr str 
iDisplay seq = flatten 0 [(seq, 0)]
iDisplay :: Iseq -> String -- Turn an iseq into a string
iConcat :: [Iseq] -> Iseq
iConcat (car:cdr) = car `iAppend` (iConcat cdr)
iConcat [] = iNil
iFWNum :: Int -> Int -> Iseq
iFWNum width n
    = iStr (replicate (width - length digits) ' ' ++ digits)
    where
    digits = show n
iLayn :: [Iseq] -> Iseq
iLayn seqs = iConcat (map lay_item (zip [1..] seqs))
                where
                lay_item (n, seq)
                    = iConcat [ iFWNum 4 n, iStr ") ", iIndent seq, iNewline ]
iInterleave :: Iseq -> [Iseq] -> Iseq
iInterleave  _ [s] = s
iInterleave sep (car:cdr) = car `iAppend` sep `iAppend` (iInterleave sep cdr)
iInterleave INil s = iConcat s
iInterleave sep [] = iNil

binop = ["+", "-", "*", "/", "<", "<=", "==", "˜=", ">=", ">", "&", "|"]

pprExpr :: CoreExpr -> Iseq
pprExpr (EVar v) = iStr v
pprExpr (ENum n) = iNum n
pprExpr (EAp (EAp (EVar biop) e1) e2)  --TODO: 1.5.5 カッコをいい感じにする
    | elem biop binop
    = iConcat [ pprAExpr e1, iStr (" " ++ biop ++ " "), pprAExpr e2 ]
pprExpr (EAp e1 e2) = (pprExpr e1) `iAppend` (iStr " ") `iAppend` (pprAExpr e2)
pprExpr (ELet isrec defns expr)
    = iConcat [ iStr keyword, iNewline,
                iStr " ", iIndent (pprDefns defns), iNewline,
                iStr "in ", pprExpr expr ]
        where
        keyword | not isrec = "let"
                | isrec = "letrec"
pprExpr (ECase expr alters)
    = iConcat [ iStr "case", iStr " ", pprExpr expr, iNewline,
                iStr " ", iIndent (pprAlters alters), iNewline ]
pprExpr (ELam var expr)
    = iConcat [iConcat (map iStr var), iStr ". ", pprExpr expr]

pprDefns :: [(Name, CoreExpr)] -> Iseq
pprDefns defns = iInterleave sep (map pprDefn defns)
                    where
                    sep = iConcat [ iStr ";", iNewline ]

pprDefn :: (Name, CoreExpr) -> Iseq
pprDefn (name, expr) = iConcat [ iStr name, iStr " = ", iIndent (pprExpr expr) ]

pprint :: CoreProgram -> String
pprint prog = iDisplay (pprProgram prog)

pprAlters :: [(Int, [Name], Expr Name)] -> Iseq
pprAlters alters
    = iInterleave sep (map pprAlter alters)
    where
    sep = iConcat [ iStr ";", iNewline ]

pprAlter :: (Int, [Name], Expr Name) -> Iseq
pprAlter (tag, var, expr)
    = iConcat [iNum tag, iConcat (map iStr var), iStr " -> ", iIndent (pprExpr expr) ]

pprAExpr :: CoreExpr -> Iseq
pprAExpr e | isAtomicExpr e = pprExpr e
pprAExpr e | otherwise =  (iStr "(") `iAppend` pprExpr e `iAppend` (iStr ")")

pprProgram :: CoreProgram -> Iseq
pprProgram scdefns
    = iInterleave sep (map pprScDefn scdefns)
    where
    sep = iConcat [ iStr ";", iNewline ]

pprScDefn :: CoreScDefn -> Iseq
pprScDefn (name, var, expr)
    = iConcat [iStr name, iConcat (map iStr var), iStr " = ", pprExpr expr]

flatten :: Int -> [(Iseq, Int)] -> String
flatten _ [] = ""
flatten col ((INewline, indent) : seqs)
    = '\n' : (replicate indent ' ') ++ (flatten indent seqs)
flatten col ((IIndent seq, indent) : seqs)
    = flatten col ((seq, col) : seqs)
flatten col ((IStr seq, indent) : seqs)
    = seq ++ (flatten col seqs)
flatten col ((INil, indent) : seqs)
    = flatten col seqs
flatten col ((IAppend seq1 seq2, indent) : seqs)
    = flatten col ((seq1, indent) : (seq2, indent) : seqs)
    
type Token = (Int, String)

twoCharOps = ["==", "˜=", ">=", "<=", "->"]
clex :: Int -> String -> [Token]
clex _ [] = []
clex n (c1:c2:cs) | c1 == '|' && c2 == '|' = clex n (dropWhile (/= '\n') cs)
clex n (c1:c2:cs) | elem (c1:c2:[]) twoCharOps =(n, (c1:c2:[])) : clex n cs
clex n (c:cs) |  c == '\n' = clex (n + 1) cs
clex n (c:cs) | isSpace c = clex n cs
clex n (c:cs) | isDigit c = (n, num_token) : clex n rest_cs
            where
            num_token = c : takeWhile isDigit cs
            rest_cs = dropWhile isDigit cs
clex n (c:cs) | isAlpha c = (n, var_tok) : clex n rest_cs
            where
            isIdChar c = isAlpha c || isDigit c || (c == '_')
            var_tok = c : takeWhile isIdChar cs
            rest_cs = dropWhile isIdChar cs
clex n (c:cs) = (n, [c]) : clex n cs

type Parser a = [Token] -> [(a, [Token])]
pLit :: String -> Parser String
pLit s [] = []
pLit s ((n, tok):toks) | s == tok = [(s, toks)]
                        | otherwise = []

pVar :: Parser String
pVar [] = []

pAlt :: Parser a -> Parser a -> Parser a
pAlt p1 p2 toks = (p1 toks) ++ (p2 toks)

pThen :: (a -> b -> c) -> Parser a -> Parser b -> Parser c
pThen combine p1 p2 toks
    = [ (combine v1 v2, toks2) | (v1,toks1) <- p1 toks, (v2,toks2) <- p2 toks1]

--syntax :: [Token] -> CoreProgram

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

main :: IO ()
main = putStrLn $ iDisplay $ pprExpr (ELet nonRecursive [("att", ENum 2)] (EAp (EAp (EVar "+") (EVar "att")) (EVar "1")))
```

**33ページまでは動く.パーサの所を読んでる途中**