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

# 7日目

## 38ページ

書き終えたのでコンパイルする.
いろいろwarningが出るのでできるだけ潰す.
syntaxが壊れてるので直す.pExprがまずいっぽい.
バグってたのpApとpBinopのせいだったし,やっぱり著者もわかって実装しろって言ってたんだな.注意書きにこの2つを実装するなって書いてあった.
そして輝く"Syntax Error"! ヘィ!

なんとか

```
f = 3;
g x y = let
z = x
in z;
h x = case let
y = x
in y
<1> -> 2;
<2> -> 5
```

を正しくパースできるようになった.やったー.

書いたソースが300行超えてきたのでこれからdiffを取る.
今日は一応完全版を貼る.

**Exercise 1.21が終わった.次は1.22をやる.**

```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
    deriving(Show)

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 _) = True
isAtomicExpr (ENum _) = True
isAtomicExpr _ = 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 seq1 INil = seq1
iAppend INil seq2 = seq2
iAppend seq1 seq2 = IAppend seq1 seq2
iNum n = iStr (show n)
iIndent seq1 = IIndent seq1
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 seq1 = flatten 0 [(seq1, 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, seq1)
                    = iConcat [ iFWNum 4 n, iStr ") ", iIndent seq1, 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 _ [] = iNil

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

pprExpr :: CoreExpr -> Iseq
pprExpr (EVar v) = iStr v
pprExpr (ENum n) = iNum n
pprExpr (EConstr tag arity) = iConcat [ (iStr "Pack{"), (iNum tag), (iStr ", "), (iNum arity), (iStr "}") ]
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,
                iIndent (pprDefns defns), iNewline,
                iStr "in ", pprExpr expr ]
        where
        keyword = if isrec then "letrec" else "let"
pprExpr (ECase expr alters)
    = iConcat [ iStr "case", iStr " ", pprExpr expr, iNewline,
                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 [iStr "<", iNum tag, iStr ">", iStr (unwords 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, if (var == []) then iNil else iStr " ", iStr (unwords var), iStr " = ", pprExpr expr]

flatten :: Int -> [(Iseq, Int)] -> String
flatten _ [] = ""
flatten _ ((INewline, indent) : seqs)
    = '\n' : (replicate indent ' ') ++ (flatten indent seqs)
flatten col ((IIndent seq1, indent) : seqs) -- TODO: indent properly
    = flatten col ((seq1, col) : seqs)
flatten col ((IStr seq1, _) : seqs)
    = seq1 ++ (flatten col seqs)
flatten col ((INil, _) : seqs)
    = flatten col seqs
flatten col ((IAppend seq1 seq2, indent) : seqs)
    = flatten col ((seq1, indent) : (seq2, indent) : seqs)
    
type Token = (Int, String)
twoCharOps :: [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 d = isAlpha d || isDigit d || (d == '_')
            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 = pSat (== s)

keywords :: [String]
keywords = ["let", "letrec", "case", "in", "of", "Pack"]
pVar :: Parser String
pVar = pSat (\s@(x:_) -> isAlpha x && notElem s keywords)

pNum :: Parser Int
pNum = pApply (pSat (\(x:_) -> isDigit x)) (\x -> read x :: Int)

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]

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 = (take 1) . (pThen (:) a ((pThen (\_ x -> x) b (pOneOrMoreWithSep a b)) `pAlt` (pEmpty [])))

pSat :: (String -> Bool) -> Parser String
pSat pd = pSatpred
    where   pSatpred ((_, 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 (pApply pBinop EVar) pExpr
    --`pAlt`  
    pThen4 mk_let (pLit "let") pDefns (pLit "in") pExpr
    `pAlt`  pThen4 mk_letrec (pLit "letrec") pDefns (pLit "in") pExpr
    `pAlt`  pThen4 mk_case (pLit "case") pExpr (pLit "of") pAlts
    `pAlt`  pThen4 mk_lam (pLit "\\") (pOneOrMore pVar) (pLit ".") pExpr
    `pAlt`  pAexpr
    where
    mk_ap e a = EAp e a
    mk_binop exp1 op exp2 = EAp (EAp op exp1) exp2
    mk_let _ defns _ e = ELet nonRecursive  defns  e
    mk_letrec _ defns _ e = ELet nonRecursive defns e
    mk_case _ e _ a = ECase e a
    mk_lam _ v _ e = ELam v e

pAexpr :: Parser CoreExpr
pAexpr =    pApply pVar EVar
    `pAlt`  pApply pNum ENum
    `pAlt`  pThen mk_pack2 (pThen4 mk_pack (pThen (\_ _ -> pEmpty []) (pLit "Pack") (pLit "{")) pNum (pLit ",") pNum) (pLit "}")
    `pAlt`  pThen3 mk_pexpr (pLit "(") pExpr (pLit ")")
    where
    mk_pack _ n1 _ n2 = EConstr n1 n2
    mk_pack2 p _ = p
    mk_pexpr _ e _ = e

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

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

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

pAlter :: Parser CoreAlt
pAlter = pThen4 mk_alter (pThen3 mk_tag (pLit "<") pNum (pLit ">")) (pZeroOrMore pVar) (pLit "->") pExpr
        where
        mk_tag _ n _ = n
        mk_alter n v _ e = (n, v, e)

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, []) : _) = prog
    take_first_parse (_ : others) = take_first_parse others
    take_first_parse _ = error "Syntax error"

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

main :: IO ()
--main = putStrLn $ iDisplay $ pprExpr (ELet nonRecursive [("att", ENum 2)] (EAp (EAp (EVar "+") (EVar "att")) (EVar "1")))
main = putStrLn( pprint $ parse  "f=3;\ng x y = let z = x in z ;\nh x = case (let y = x in y) of\n<1> -> 2 ;\n<2> -> 5")
--main = putStrLn $ show $ pOneOrMoreWithSep (pLit "x") (pLit ";") [(1,"x"),(1,";"),(1,"x") ,(1,";"),(2,"x"),(2,";"),(2,"x"),(2,";"),(2,"x") ]
--main = putStrLn $ show $ pExpr [(2,"let"),(2,"z"),(2,"="),(2,"x"),(2,"in"),(2,"z")]
--main = putStrLn $ pprint $ syntax [(1,"f"),(1,"="),(1,"3") ,(1,";"),(2,"g"),(2,"x"),(2,"y"),(2,"="), (2,"let"),(2,"z"),(2,"="),(2,"x"),(2,"in"),(2,"z"),(2,";"),(3,"h"),(3,"x"),(3,"="),(3,"case"),(3,"("),(3,"let"),(3,"y"),(3,"="),(3,"x"),(3,"in"),(3,"y"),(3,")"),(3,"of"),(4,"<"),(4,"1"),(4,">"),(4,"->"),(4,"2"),(4,";"),(5,"<"),(5,"2"),(5,">"),(5,"->"),(5,"5")]
```