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(プリティプリンタライブラリに肉付けする)の練習問題2.を解いてみる。
2.
コード(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, nest)
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
a = JArray [JNumber 10, JBool True];
b = JObject [("a", JBool True), ("b", JBool False), ("c", a)]
c = JArray [JNumber 20, JString "Haskell"]
d = JObject [("a", JNumber 1.0), ("b", b),("c", c)]
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
, nest) 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 ' ')
-- 練習問題2のnest
nest :: Int -> Doc -> Doc
nest width x = indent 0 [x]
where indent n (d:ds) =
case d of
Empty -> indent n ds
Char '(' -> Line <> addSpace (n * width) <> Char '(' <> indent (n + 1) ds
Char '[' -> Line <> addSpace (n * width) <> Char '[' <> indent (n + 1) ds
Char '{' -> Line <> addSpace (n * width) <> Char '{' <> indent (n + 1) ds
Char ')' -> Line <> addSpace ((n - 1) * width) <> Char ')' <> indent (n - 1) ds
Char ']' -> Line <> addSpace ((n - 1) * width) <> Char ']' <> indent (n - 1) ds
Char '}' -> Line <> addSpace ((n - 1) * width) <> Char '}' <> indent (n - 1) ds
Char c -> Char c <> indent n ds
Text s -> Text s <> indent n ds
Line -> Line <> addSpace ((n - 1) * width) <> indent n ds
a `Concat` b -> indent n (a:b:ds)
a `Union` b -> ( a <> indent n ds) `Union`
(b <> addSpace ((n - 1) * width) <> indent n ds)
indent _ _ = Empty
入出力結果(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 d
*PrettyJSON> let value' = nest 4 value
*PrettyJSON> putStrLn(pretty 10 value)
{"a": 1.0,
"b": {"a": true,
"b": false,
"c": [10.0,
true ] },
"c": [20.0,
"Haskell"
] }
*PrettyJSON> putStrLn(pretty 10 value')
{"a": 1.0,
"b":
{"a": true,
"b": false,
"c":
[10.0,
true
]
},
"c":
[20.0,
"Haskell"
]
}
*PrettyJSON> putStrLn(pretty 20 value)
{"a": 1.0,
"b": {"a": true,
"b": false,
"c": [10.0, true ]
}, "c": [20.0,
"Haskell" ] }
*PrettyJSON> putStrLn(pretty 20 value')
{"a": 1.0, "b":
{"a": true,
"b": false,
"c":
[10.0, true
]
}, "c":
[20.0, "Haskell"
]
}
*PrettyJSON> putStrLn(pretty 30 value)
{"a": 1.0, "b": {"a": true,
"b": false, "c": [10.0, true ]
}, "c": [20.0, "Haskell" ] }
*PrettyJSON> putStrLn(pretty 30 value')
{"a": 1.0, "b":
{"a": true, "b": false,
"c":
[10.0, true
]
}, "c":
[20.0, "Haskell"
]
}
*PrettyJSON> :quit
Leaving GHCi.
$
0 コメント:
コメントを投稿