Real World Haskell
実戦で学ぶ関数型言語プログラミング
Bryan O'Sullivan, John Goerzen, Don Stewart(著)
山下 伸夫, 伊東 勝利
株式会社タイムインターメディア(翻訳)
開発環境
- OS X Lion - Apple(OS)
- BBEdit - Bare Bones Software, Inc.(Text Editor)
- プログラミング言語: Haskell (純粋関数型)
Real World Haskell』(Bryan O'Sullivan、John Goerzen、Don Stewart(著)、山下 伸夫、伊東 勝利、株式会社タイムインターメディア(翻訳)、オライリー・ジャパン、2009年、ISBN978-4-87311-423-3)の5章(ライブラリを書く: JSONデータの走査)の5.13(プリティプリンタライブラリに肉付けする)の練習問題1.を解いてみる。
1.
コード(BBEdit)
PrettyJSON.hs
-- file: PrettyJSON.hs module PrettyJSON ( renderJValue ) where import Numeric (showHex) import Data.Bits (shiftR, (.&.)) import Data.Char (ord) import SimpleJSON (JValue(..)) import Prettify(Doc, text, double, (<>), char, hcat, fsep, punctuate, compact, pretty, fill) renderJValue :: JValue -> Doc renderJValue (JBool True) = text "true" renderJValue (JBool False) = text "false" renderJValue JNull = text "null" renderJValue (JNumber num) = double num renderJValue (JString str) = string str renderJValue (JArray ary) = series '[' ']' renderJValue ary renderJValue (JObject obj) = series '{' '}' field obj where field (name, value) = string name <> text ": " <> renderJValue value string :: String -> Doc string = enclose '"' '"' . hcat . map oneChar enclose :: Char -> Char -> Doc -> Doc enclose left right x = char left <> x <> char right oneChar :: Char -> Doc oneChar c = case lookup c simpleEscapes of Just r -> text r Nothing | mustEscape c -> hexEscape c | otherwise -> char c where mustEscape c = c < ' ' || c == '\x7f' || c > '\xff' simpleEscapes :: [(Char, String)] simpleEscapes = zipWith ch "\b\n\f\r\t\\\"/" "bnfrt\\\"/" where ch a b = (a, ['\\', b]) smallHex :: Int -> Doc smallHex x = text "\\u" <> text (replicate (4 - length h) '0') <> text h where h = showHex x "" astral :: Int -> Doc astral n = smallHex (a + 0xd800) <> smallHex ( b + 0xdc00) where a = (n `shiftR` 10) .&. 0x3ff b = n .&. 0x3ff hexEscape :: Char -> Doc hexEscape c | d < 0x10000 = smallHex d | otherwise = astral (d - 0x10000) where d = ord c series :: Char -> Char -> (a -> Doc) -> [a] -> Doc series open close item = enclose open close . fsep .punctuate (char ',') . map item
SimpleJSON.hs
-- file: SimpleJSON.hs module SimpleJSON ( JValue(..) , getString , getInt , getDouble , getBool , getObject , getArray , isNull ) where data JValue = JString String | JNumber Double | JBool Bool | JNull | JObject [(String, JValue)] | JArray [JValue] deriving (Eq, Ord, Show) getString :: JValue -> Maybe String getString (JString s) = Just s getString _ = Nothing getInt :: JValue -> Maybe Int getInt (JNumber n) = Just (truncate n) getInt _ = Nothing getDouble :: JValue -> Maybe Double getDouble (JNumber n) = Just n getDouble _ = Nothing getBool :: JValue -> Maybe Bool getBool (JBool b) = Just b getBool _ = Nothing getObject :: JValue -> Maybe [(String, JValue)] getObject (JObject o) = Just o getObject _ = Nothing getArray :: JValue -> Maybe [JValue] getArray (JArray a) = Just a getArray _ = Nothing isNull :: JValue -> Bool isNull v = v == JNull
Prettify.hs
-- file: PrettyStub.hs module Prettify ( Doc , empty , char , text , double , (<>) , hcat , fsep , punctuate , compact , pretty , fill) where import SimpleJSON data Doc = Empty | Char Char | Text String | Line | Concat Doc Doc | Union Doc Doc deriving (Show, Eq) empty :: Doc empty = Empty char :: Char -> Doc char c = Char c text :: String -> Doc text "" = Empty text s = Text s double :: Double -> Doc double d = text (show d) line :: Doc line = Line (<>) :: Doc -> Doc -> Doc Empty <> a = a a <> Empty = a a <> b = a `Concat` b hcat :: [Doc] -> Doc hcat = fold (<>) fold :: (Doc -> Doc -> Doc) -> [Doc] -> Doc fold f = foldr f Empty fsep :: [Doc] -> Doc fsep = fold (>) (>) :: Doc -> Doc -> Doc x > y = x <> softline <> y softline :: Doc softline = group line group :: Doc -> Doc group x = flatten x `Union` x flatten :: Doc -> Doc flatten (x `Concat` y) = flatten x `Concat` flatten y flatten Line = Char ' ' flatten ( x `Union` _ ) = flatten x flatten other = other compact :: Doc -> String compact x = transform [x] where transform [] = "" transform (d:ds) = case d of Empty -> transform ds Char c -> c:transform ds Text s -> s ++ transform ds Line -> '\n': transform ds a `Concat` b -> transform (a:b:ds) _ `Union` b -> transform (b:ds) pretty :: Int -> Doc -> String pretty width x = best 0 [x] where best col (d:ds) = case d of Empty -> best col ds Char c -> c : best (col + 1) ds Text s -> s ++ best (col + length s) ds Line -> '\n' : best 0 ds a `Concat` b -> best col (a:b:ds) a `Union` b -> nicest col (best col (a:ds)) (best col (b:ds)) best _ _ = "" nicest col a b | (width - least) `fits` a = a | otherwise = b where least = min width col fits :: Int -> String -> Bool w `fits` _ | w < 0 = False w `fits` "" = True w `fits` ('\n':_) = True w `fits` (c:cs) = (w - 1) `fits` cs punctuate :: Doc -> [Doc] -> [Doc] punctuate p [] = [] punctuate p [d] = [d] punctuate p (d:ds) = (d <> p): punctuate p ds -- 練習問題1のfill 与えられたカラム幅まで文書に空白を追加する fill :: Int -> Doc -> Doc fill width x = best 0 [x] where best col (d:ds) = case d of Empty -> best col ds Char c -> Char c <> best (col + 1) ds Text s -> Text s <> best (col + length s) ds Line -> addSpace (width - col) <> Line <> best 0 ds a `Concat` b -> best col (a:b:ds) a `Union` b -> nicest col (best col (a:ds)) (best col (b:ds)) best col [] = addSpace (width - col) nicest col a b | width - col > 0 = a | otherwise = b addSpace :: Int -> Doc addSpace n | n < 0 = Empty | otherwise = Text (replicate n ' ')
入出力結果(Terminal, ghci)
$ ghci GHCi, version 7.4.2: http://www.haskell.org/ghc/ :? for help Loading package ghc-prim ... linking ... done. Loading package integer-gmp ... linking ... done. Loading package base ... linking ... done. Prelude> :load PrettyJSON [2 of 3] Compiling Prettify ( Prettify.hs, interpreted ) [3 of 3] Compiling PrettyJSON ( PrettyJSON.hs, interpreted ) Ok, modules loaded: PrettyJSON, SimpleJSON, Prettify. *PrettyJSON> let value = renderJValue (JObject [("f",JNumber 1),("q",JBool True)]) *PrettyJSON> let value' = fill 50 value *PrettyJSON> value Concat (Concat (Char '{') (Concat (Concat (Concat (Concat (Concat (Concat (Concat (Char '"') (Char 'f')) (Char '"')) (Text ": ")) (Text "1.0")) (Char ',')) (Union (Char ' ') Line)) (Concat (Concat (Concat (Concat (Concat (Char '"') (Char 'q')) (Char '"')) (Text ": ")) (Text "true")) (Union (Char ' ') Line)))) (Char '}') *PrettyJSON> value' Concat (Char '{') (Concat (Char '"') (Concat (Char 'f') (Concat (Char '"') (Concat (Text ": ") (Concat (Text "1.0") (Concat (Char ',') (Concat (Char ' ') (Concat (Char '"') (Concat (Char 'q') (Concat (Char '"') (Concat (Text ": ") (Concat (Text "true") (Concat (Char ' ') (Concat (Char '}') (Text " "))))))))))))))) *PrettyJSON> putStrLn(pretty 10 value) {"f": 1.0, "q": true } *PrettyJSON> putStrLn(pretty 10 value') {"f": 1.0, "q": true } *PrettyJSON> putStrLn(pretty 20 value) {"f": 1.0, "q": true } *PrettyJSON> putStrLn(pretty 20 value') {"f": 1.0, "q": true } *PrettyJSON> putStrLn(pretty 30 value) {"f": 1.0, "q": true } *PrettyJSON> putStrLn(pretty 30 value') {"f": 1.0, "q": true } *PrettyJSON> :quit Leaving GHCi. $
fill関数の追加は有意義な改善の1つみたいだけど、実際にはどういう時に有意義なのかな〜(有意義さが分からないってことは、問題の意図を間違えているのかも。。)
0 コメント:
コメントを投稿