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

# 12日目

やるきがでない

## 2.3.4
「コンパイル」はステートマシンに必要な情報を揃えること.
つまり,入力から初期状態を作ることしかしない.

## 2.3.5
むつかしい
Taking a stepがわからない

```hs
import Language
import Utils

runProg :: String -> String
runProg = showResults . eval . compile . parse

compile :: CoreProgram -> TiState

eval :: TiState -> [TiState]

showResults :: [TiState] -> String

type TiState = (TiStack, TiDump, TiHeap, TiGlobals, TiStats)
type TiStack = [Addr]
data TiDump = DummyTiDump
initialTiDump = DummyTiDump
type TiHeap = Heap Node
data Node = NAp Addr Addr -- Application
    | NSupercomb Name [Name] CoreExpr -- Supercombinator
    | NNum Int

type TiGlobals = ASSOC Name Addr
tiStatInitial :: TiStats
tiStatIncSteps :: TiStats -> TiStats
tiStatGetSteps :: TiStats -> Int
type TiStats = Int
tiStatInitial = 0
tiStatIncSteps s = s+1
tiStatGetSteps s = s

applyToStats :: (TiStats -> TiStats) -> TiState -> TiState
applyToStats stats_fun (stack, dump, heap, sc_defs, stats) = (stack, dump, heap, sc_defs, stats_fun stats)
compile program = (initial_stack, initialTiDump, initial_heap, globals, tiStatInitial)
    where
    sc_defs = program ++ preludeDefs ++ extraPreludeDefs
    (initial_heap, globals) = buildInitialHeap sc_defs
    initial_stack = [address_of_main]
    address_of_main = aLookup globals "main" (error "main is not defined")

extraPreludeDefs = []

buildInitialHeap :: [CoreScDefn] -> (TiHeap, TiGlobals)
buildInitialHeap sc_defs = mapAccuml allocateSc hInitial sc_defs

allocateSc :: TiHeap -> CoreScDefn -> (TiHeap, (Name, Addr))
allocateSc heap (name, args, body) = (heap', (name, addr))
    where
    (heap', addr) = hAlloc heap (NSupercomb name args body)

eval state = state : rest_states
    where
    rest_states | tiFinal state = []
                | otherwise = eval next_state
    next_state = doAdmin (step state)

doAdmin :: TiState -> TiState
doAdmin state = applyToStats tiStatIncSteps state

tiFinal :: TiState -> Bool
tiFinal ([sole_addr], dump, heap, globals, stats) = isDataNode (hLookup heap sole_addr)
tiFinal ([], dump, heap, globals, stats) = error "Empty stack!"
tiFinal state = False -- Stack contains more than one item

isDataNode :: Node -> Bool
isDataNode (NNum n) = True
isDataNode node = False

step :: TiState -> TiState
step state = dispatch (hLookup heap (hd stack))
    where
    (stack, dump, heap, globals, stats) = state
    dispatch (NNum n) = numStep state n
    dispatch (NAp a1 a2) = apStep state a1 a2
    dispatch (NSupercomb sc args body) = scStep state sc args body

numStep :: TiState -> Int -> TiState
numStep state n = error "Number applied as a function!"

apStep :: TiState -> Addr -> Addr -> TiState
apStep (stack, dump, heap, globals, stats) a1 a2 = (a1 : stack, dump, heap, globals, stats)


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;\n i = g (1 + 2 * 3) (5 - 1 / 2)")
--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")]
```

**58ページまで読んだ**