11日目
ネット環境がなくて2日間が空いた.頑張って継続して読む.
2.3.2
なんか著者によるとparseはチャプター1で定義されたlanguageモジュールに入れたつもりだったらしい.
チャプター1で作った関数を全部Language.hsに突っ込む.
適当にmodule Languageとかしてあげる.
utilsに必要なものが入ってるからimportしてね,ってめっちゃずるくないですか.
diffとったやーつ
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潰したやーつ
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までのソースコードを整理した.