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

# 11日目

ネット環境がなくて2日間が空いた.頑張って継続して読む.

## 2.3.2
なんか著者によるとparseはチャプター1で定義されたlanguageモジュールに入れたつもりだったらしい.
チャプター1で作った関数を全部Language.hsに突っ込む.
適当にmodule Languageとかしてあげる.
utilsに必要なものが入ってるからimportしてね,ってめっちゃずるくないですか.
diffとったやーつ

```hs:Language.hs
+module Language where
 +import Utils
  import Data.Char
  
  data Expr a
 @@ -25,10 +27,10 @@ recursive = True
  nonRecursive = False
  
  bindersOf :: [(a,b)] -> [a]
 -bindersOf defns = [name | (name, rhs) <- defns]
 +bindersOf defns = [name | (name, _) <- defns]
  
  rhssOf :: [(a,b)] -> [b]
 -rhssOf defns = [rhs | (name, rhs) <- defns]
 +rhssOf defns = [rhs | (_, rhs) <- defns]
  
  type Alter a = (Int, [a], Expr a)
  type CoreAlt = Alter Name
 @@ -69,7 +71,7 @@ iNil = INil
  iAppend seq1 INil = seq1
  iAppend INil seq2 = seq2
  iAppend seq1 seq2 = IAppend seq1 seq2
 -iNum n = iStr (show n)
 +iNum n = iStr (shownum 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
 @@ -80,9 +82,9 @@ iConcat (car:cdr) = car `iAppend` (iConcat cdr)
  iConcat [] = iNil
  iFWNum :: Int -> Int -> Iseq
  iFWNum width n
 -    = iStr (replicate (width - length digits) ' ' ++ digits)
 +    = iStr (space (width - length digits) ++ digits)
      where
 -    digits = show n
 +    digits = shownum n
  iLayn :: [Iseq] -> Iseq
  iLayn seqs = iConcat (map lay_item (zip [1..] seqs))
                  where
 @@ -155,7 +157,7 @@ pprScDefn (name, var, expr)
  flatten :: Int -> [(Iseq, Int)] -> String
  flatten _ [] = ""
  flatten _ ((INewline, indent) : seqs)
 -    = '\n' : (replicate indent ' ') ++ (flatten indent seqs)
 +    = '\n' : (space indent) ++ (flatten indent seqs)
  flatten col ((IIndent seq1, indent) : seqs) -- TODO: indent properly
      = flatten col ((seq1, col) : seqs)
  flatten col ((IStr seq1, _) : seqs)
 @@ -250,7 +252,6 @@ pExpr =     pApply (pOneOrMore pAexpr) mk_ap
      `pAlt`  pAexpr
      where
      mk_ap e = foldl1 EAp e
 -    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
 @@ -335,10 +336,3 @@ assembleOp :: CoreExpr -> PartialExpr -> CoreExpr
  assembleOp e1 NoOp = e1
  assembleOp e1 (FoundOp op e2) = EAp (EAp (EVar op) e1) e2
  
 -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")]
```

waring潰したやーつ

```hs:Utils.hs
module Utils where
-- The following definitions are used to make some synonyms for routines
-- in the Gofer prelude to be more Miranda compatible
shownum :: Show a => a -> String
shownum n = show n
hd :: [a] -> a
hd = head -- in Gofer standard prelude
tl :: [a] -> [a]
tl = tail -- in Gofer standard prelude
zip2 :: [a] -> [b] -> [(a,b)]
zip2 = zip -- in Gofer standard prelude
-- can’t do anything about # = length, since # not binary.
hInitial :: Heap a
hAlloc :: Heap a -> a -> (Heap a, Addr)
hUpdate :: Heap a -> Addr -> a -> Heap a
hFree :: Heap a -> Addr -> Heap a
hLookup :: Heap a -> Addr -> a
hAddresses :: Heap a -> [Addr]
hSize :: Heap a -> Int
hNull :: Addr
hIsnull :: Addr -> Bool
showaddr :: Addr -> [Char]
type Heap a = (Int, [Int], [(Int, a)])
type Addr = Int
hInitial = (0, [1..], [])
hAlloc (size, (next:free), cts) n = ((size+1, free, (next,n) : cts),next)
hAlloc (_, [], _ ) _ = error "mel"
hUpdate (size, free, cts) a n = (size, free, (a,n) : remove cts a)
hFree (size, free, cts) a = (size-1, a:free, remove cts a)
hLookup (_, _, cts) a = aLookup cts a (error ("can’t find node " ++ showaddr a ++ " in heap"))

hAddresses (_, _, cts) = [addr | (addr, _) <- cts]

hSize (size, _, _) = size
hNull = 0
hIsnull a = a == 0
showaddr a = "#" ++ shownum a -- Print # to identify addresses
remove :: [(Int,a)] -> Int -> [(Int,a)]
remove [] a = error ("Attempt to update or free nonexistent address #" ++ shownum a)
remove ((a', n):cts) a = if a == a' then cts else (a',n) : remove cts a

type ASSOC a b = [(a,b)]
aLookup :: Eq a => [(a, t)] -> a -> t -> t
aLookup [] _ def = def
aLookup ((k,v):bs) k' def = if k == k' then v else aLookup bs k' def
aDomain :: ASSOC a b -> [a]
aDomain alist = [key | (key, _) <- alist]

aRange :: ASSOC a b -> [b]
aRange alist = [val | (_, val) <- alist]
aEmpty :: [a]
aEmpty = []
getName :: NameSupply -> [Char] -> (NameSupply, [Char])
getNames :: NameSupply -> [[Char]] -> (NameSupply, [[Char]])
initialNameSupply :: NameSupply
type NameSupply = Int
initialNameSupply = 0
getName name_supply prefix = (name_supply+1, makeName prefix name_supply)
getNames name_supply prefixes = (name_supply + length prefixes, zipWith makeName prefixes [name_supply..])
makeName :: Show a => [Char] -> a -> [Char]
makeName prefix ns = prefix ++ "_" ++ shownum ns
setFromList :: (Ord a) => [a] -> Set a
setToList :: (Ord a) => Set a -> [a]
setUnion :: (Ord a) => Set a -> Set a -> Set a
setIntersection :: (Ord a) => Set a -> Set a -> Set a
setSubtraction :: (Ord a) => Set a -> Set a -> Set a
setElementOf :: (Ord a) => a -> Set a -> Bool
setEmpty :: (Ord a) => Set a
setIsEmpty :: (Ord a) => Set a -> Bool
setSingleton :: (Ord a) => a -> Set a
setUnionList :: (Ord a) => [Set a] -> Set a
type Set a = [a] -- Ordered by the sort function
setEmpty = []
setIsEmpty s = null s
setSingleton x = [x]
setFromList = rmdup . sort
    where
    rmdup [] = []
    rmdup [x] = [x]
    rmdup (x:y:xs) = if x == y then rmdup (y:xs) else x: rmdup (y:xs)
setToList xs = xs
setUnion [] [] = []
setUnion [] (b:bs) = (b:bs)
setUnion (a:as) [] = (a:as)
setUnion (a:as) (b:bs)
    | a < b = a: setUnion as (b:bs)
    | a == b = a: setUnion as bs
    | a > b = b: setUnion (a:as) bs
    | otherwise = error "bourne"
setIntersection [] [] = []
setIntersection [] (_:_) = []
setIntersection (_:_) [] = []
setIntersection (a:as) (b:bs)
    | a < b = setIntersection as (b:bs)
    | a == b = a: setIntersection as bs
    | a > b = setIntersection (a:as) bs
    | otherwise = error "tas"
setSubtraction [] [] = []
setSubtraction [] (_:_) = []
setSubtraction (a:as) [] = (a:as)
setSubtraction (a:as) (b:bs) | a < b = a: setSubtraction as (b:bs)
    | a == b = setSubtraction as bs
    | a > b = setSubtraction (a:as) bs
    | otherwise = error "menia"
setElementOf _ [] = False
setElementOf x (y:ys) = x==y || (x>y && setElementOf x ys)
setUnionList = foldll setUnion setEmpty
first :: (t, t1) -> t
first (a, _) = a
second :: (t, t1) -> t1
second (_, b) = b
-- zipWith is defined in standard prelude
foldll :: (a -> b -> a) -> a -> [b] -> a
foldll = foldl -- in Gofer standard prelude.
mapAccuml :: (a -> b -> (a, c)) -- Function of accumulator and element
-- input list, returning new
-- accumulator and element of result list
    -> a -- Initial accumulator
    -> [b] -- Input list
    -> (a, [c]) -- Final accumulator and result list

mapAccuml _ acc [] = (acc, [])
mapAccuml f acc (x:xs) = (acc2, x':xs')
    where
    (acc1, x') = f acc x
    (acc2, xs') = mapAccuml f acc1 xs
sort :: Ord a => [a] -> [a]
sort [] = []
sort [x] = [x]
sort (x:xs) = [ y | y <- xs, y < x] ++ x : [ y | y <- xs, y >= x ]
space :: Int -> [Char]
space n = take n (repeat ' ')
```

やる気がでないので終わり.ちょっとまずいのでなんとかする.
あした空白文字をいい感じにする

**2.3.3までのソースコードを整理した.**