本文介绍使用Haskell开发一个处理JSON数据的小型库的过程，包括定义数据类型、解析JSON值、模块定义、编译Haskell源代码以及美化输出等功能。
Chapter 5. Writing a Library: Working with JSON Data
A Whirlwind Tour of JSON
本章将开发一个小的，但完整的Haskell 库。这个库以JSON 格式(JavaScript Object Notation)来操作和序列化数据。
Representing JSON Data in Haskell
用algebraic 数据类型来表示JSON 数据类型
data JValue = JString String
| JNumber Double
| JBool Bool
| JNull
| JObject [(String, JValue)]
| JArray [JValue]
deriving (Eq, Ord, Show)
对每一个JSON 类型，我们提供一个不同的值构造器。其中一些构造器拥有参数：如果我们想创建一个JSON string，就必须提供一个String 值作为JString 构造器的参数。
getString :: JValue -> Maybe String
getString (JString s) = Just s
getString _ = Nothing
getInt (JNumber n) = Just (truncate n)
getInt _ = Nothing
getDouble (JNumber n) = Just n
getDouble _ = Nothing
getBool (JBool b) = Just b
getBool _ = Nothing
getObject (JObject o) = Just o
getObject _ = Nothing
getArray (JArray a) = Just a
getArray _ = Nothing
isNull v = v == JNull
{-
ghci> JString "foo"
JString "foo"
ghci> JNumber 2.7
JNumber 2.7
ghci> :type JBool True
JBool True :: JValue
ghci> getString (JString "hello")
Just "hello"
ghci> getString (JNumber 3)
Nothing
-}
truncate 函数通过丢弃小数点将浮点数或比例数转成整数
-- import Data.Ratio
truncate 5.8 -- >5
truncate (22 % 7) -- >3
The Anatomy of a Haskell Module
定义模块的方法
-- JSON.hs
module JSON
(
JValue(..)
, getString
, getInt
, getDouble
, getBool
, getObject
, getArray
, isNull
) where
module 后接模块名，模块名必须以大写字母开头。源文件名和模块名必须相同。
模块名后接导出列表，where 关键字指出后面follow 模块体。
导出列表指出此模块中的哪些名字在其它模块中可见。
JValue 后面的特殊notation “(..)” 表示导出type 和所有构造器。
如果忽略导出列表及包围它的括号“()”，则会导出模块中的所有名字
-- module ExportEverything where
如果想要不导出任何名字（这样几乎没什么用），可以让导出列表为空。
-- module ExportNothing () 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 (JNumber n) = Just (truncate n)
getInt _ = Nothing
getDouble (JNumber n) = Just n
getDouble _ = Nothing
getBool (JBool b) = Just b
getBool _ = Nothing
getObject (JObject o) = Just o
getObject _ = Nothing
getArray (JArray a) = Just a
getArray _ = Nothing
isNull v = v == JNull
Compiling Haskell Source
ghc 生成native 代码
将源文件编译成目标文件
ghc -c JSON.hs
“-c” 选项表示仅生成目标代码，如果忽略“-c” 则ghc 会尝试生成完整的可执行程序，这会导致失败，因为我们没有写main 函数
上面的命令执行后会生成JSON.hi 和SimpleJSON.o 。前一个是interface file，含有导出的名字。后一个是object file，含有机器码。
Generating a Haskell Program and Importing Modules
链接库并生成可执行文件
-- 双击运行批处理
-- JSON.bat
ghc -c JSON.hs -- 生成库
ghc -o JSON Main.hs JSON.o -- 生成可执行文件
JSON -- 运行可执行文件
cmd.exe
------------------------------------------------------
-- JSON.hs
module JSON
(
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 (JNumber n) = Just (truncate n)
getInt _ = Nothing
getDouble (JNumber n) = Just n
getDouble _ = Nothing
getBool (JBool b) = Just b
getBool _ = Nothing
getObject (JObject o) = Just o
getObject _ = Nothing
getArray (JArray a) = Just a
getArray _ = Nothing
isNull v = v == JNull
------------------------------------------------------
-- Main.hs
module Main (main) where
import JSON
main = print (JObject [("foo", JNumber 1), ("bar", JBool False)])
Printing JSON Data
-- PutJSON.hs
module PutJSON where
import Data.List (intercalate)
import SimpleJSON
renderJValue :: JValue -> String
renderJValue (JString s) = show s
renderJValue (JNumber n) = show n
renderJValue (JBool True) = "true"
renderJValue (JBool False) = "false"
renderJValue JNull = "null"
renderJValue (JObject o) = "{" ++ pairs o ++ "}"
where pairs [] = ""
pairs ps = intercalate ", " (map renderPair ps)
renderPair (k,v) = show k ++ ": " ++ renderJValue v
renderJValue (JArray a) = "[" ++ values a ++ "]"
where values [] = ""
values vs = intercalate ", " (map renderJValue vs)
Type Inference Is a Double-Edged Sword
类型推断是把双刃剑，top level 的代码尽量自已写函数签名。
将字串格式化为字首大写
-- 不写函数签名的后果
upcaseFirst (c:cs) = (toUpper c):cs -- 如果忘记 ":cs" 就会发生隐式错误
camelCase :: String -> String
camelCase xs = concat (map upcaseFirst (words xs))
camelCase "hello,world!" -- >"Hello,world!"
A More General Look at Rendering
Haskell 有一些pretty-printing libraries。
data Doc = Empty
| Char Char
| Text String
| Line
| Concat Doc Doc
| Union Doc Doc
deriving (Show,Eq)
string :: String -> Doc
string str = undefined
text :: String -> Doc
text str = undefined
double :: Double -> Doc
double num = undefined
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
Developing Haskell Code Without Going Nuts
一种开发程序skeleton 的有用技术是编写“placeholder” 或“stub” 版的类型和函数。
我们只是提到由Prettify 模块提供string，text，和double 函数，但是其定义不做任何事情，函数只是简单的返回undefined。
-- PrettyStub.hs
module PrettyStub
(
Doc(..)
, string
, text
, double
) where
import JSON
data Doc = ToBeDefined
deriving (Show)
string :: String -> Doc
string str = undefined
text :: String -> Doc
text str = undefined
double :: Double -> Doc
double num = undefined
特殊值undefined 类型是a，所以总是typechecks，不论我们在哪里用它。
如果试图对undefined 进行evaluate 我们的程序就会crach。
{-
ghci> :type double
double :: Double -> Doc
ghci> double 3.14
*** Exception: Prelude.undefined
-}
Pretty Printing a String
string :: String -> Doc
string = enclose '"' '"' . hcat . map oneChar
这里“.” 的写法称为“Point-free style” ，它和函数复合操作符“.” 没有关系。
作为对比，下面是“pointy” 版本，它使用变量s 来引用要操作的变量
pointyString :: String -> Doc
pointyString s = enclose '"' '"' (hcat (map oneChar s))
enclose :: Char -> Char -> Doc -> Doc
enclose left right x = char left <> x <> char right
enclose 函数只是简单的将一个Doc 值用一对opening 和closing 符号包围起来。
(<>) :: Doc -> Doc -> Doc
a <> b = undefined
“<>” 函数是Doc 的“++” 运算符，它appends 两个Doc 。
hcat :: [Doc] -> Doc
hcat xs = undefined
hcat 将多个Doc (装在list 里面)连接成一个Doc。
我们的string 函数应用oneChar 函数到一个字串中的每一个字符，全部连接，并用quotes 将result 包围起来。
oneChar 函数escapes 一个字符，或简单的把它renders。
simpleEscapes 值是pairs 的列表。我们将pairs 的列表称为关联列表(association list)，或简称alist。我们的每一个alist 元素都将一个字符与一个escaped representation 表示相关联。（例如，换行这个字符其相关联的escaped 表示是“/n”）
take 4 simpleEscapes -- >[('/b',"//b"),('/n',"//n"),('/f',"//f"),('/r',"//r")]
------------------------------------------------------
-- PrettyJSON.hs
module PrettyJSON where
import JSON
import Numeric
import Data.Char (ord)
import Data.Bits (shiftR, (.&.), (.|.))
data Doc = ToBeDefined
deriving (Show)
string :: String -> Doc
string = enclose '"' '"' . hcat . map oneChar
text :: String -> Doc
text str = undefined
pointyString :: String -> Doc
pointyString s = enclose '"' '"' (hcat (map oneChar s))
enclose :: Char -> Char -> Doc -> Doc
enclose left right x = char left <> x <> char right
(<>) :: Doc -> Doc -> Doc
a <> b = undefined
char :: Char -> Doc
char c = undefined
hcat :: [Doc] -> Doc
hcat xs = undefined
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'
-- case 表达式检查一个字符是否匹配alist 中的元素。如果成功匹配就emit 它，否则就需要将它escape 成更复杂的形式。
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 ""
-- 更复杂的escaping 涉及将一个字符转成以"/u" 开头，后接四个十六进制数字，以此来表示Unicode 字符。
-- showHex 函数返回一个数的十六进制表示(需要引入Numeric 库)。
{-
ghci> showHex 114111 ""
"1bdbf"
-}
-- replicate 函数将输入参数复制指定次数并装在list 中返回
{-
ghci> replicate 5 "foo"
["foo","foo","foo","foo","foo"]
-}
astral :: Int -> Doc
astral n = smallHex (a + 0xd800) <> smallHex (b + 0xdc00)
where a = (n `shiftR` 10) .&. 0x3ff
b = n .&. 0x3ff
-- smallHex 函数有个缺陷，它表示的字符冲顶只到0xffff，而Unicode 的最大有效值是0x10ffff。
-- 为了正确表示大于0xffff 的JOSON 字符，我们用一些复杂的规则将超过0xffff 的字符分割成两部分。这给了我们一个在比特级上操作Haskel 数字的机会。
-- shiftR 和“.&.” 在Data.Bits 模块
{-
ghci> 0x10000 `shiftR` 4 :: Int
4096
ghci> 7 .&. 2 :: Int
2
-}
hexEscape :: Char -> Doc
hexEscape c | d < 0x10000 = smallHex d
| otherwise = astral (d - 0x10000)
where d = ord c
Arrays and Objects, and the Module Header
series :: Char -> Char -> (a -> Doc) -> [a] -> Doc
series open close item = enclose open close
. fsep . punctuate (char ',') . map item
-- 注意到虽然我们的类型签名要求的参数是四个，但是我们在函数定义处只列出三个。这种规则可以让我们简化函数定义，例如myLength xs = length xs 可以简化为myLength = length
fsep :: [Doc] -> Doc
fsep xs = undefined
-- fsep 函数将一个Doc 列表combines 成一个Doc。可能会对lines 做些包装，如果输出不适合单行。
punctuate :: Doc -> [Doc] -> [Doc]
punctuate p [] = []
punctuate p [d] = [d]
punctuate p (d:ds) = (d <> p) : punctuate p ds
renderJValue (JArray ary) = series '[' ']' renderJValue ary
renderJValue (JObject obj) = series '{' '}' field obj
where field (name,val) = string name
<> text ": "
<> renderJValue val
Writing a Module Header
module PrettyJSON
(
renderJValue
) where
--import JSON
import Numeric (showHex)
import Data.Char (ord)
import Data.Bits (shiftR, (.&.))
import JSON (JValue(..))
import Prettify (Doc, (<>), char, double, fsep, hcat, punctuate, text,
compact, pretty)
module Prettify
(
-- * Constructors
Doc
-- * Basic combinators
, (<>)
, empty
, char
, text
, line
-- * Derived combinators
, double
, fsep
, hcat
, punctuate
-- * Renderers
, compact
, pretty
) where
Fleshing Out the Pretty-Printing Library
-- Prettify.hs
data Doc = Empty
| Char Char
| Text String
| Line
| Concat Doc Doc
| Union Doc Doc
deriving (Show,Eq)
观察一下Doc 这个类型，实际上Doc 是一个tree。
Concat 和Union 从其它Doc 构造出新的tree。Empty，Text，Line 等是叶子。
我们模块的header 导出了Doc 这个类型名，但并不导出它的构造器，而是提供了函数来构造(Empty,Text,Char 等)。
将Prettify 中的stubbed 函数替换成真实定义的函数
{-
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 <> y = y
x <> Empty = x
x <> y = x `Concat` y -- 注意了，Concat 是DOC 的值构造器
-}
Line 构造器表示一个line break。这是一个硬line break，它总是会被打印。有时，我们想要软Line break，它只在一个line 宽过窗体或page 时被打印(稍后会引入softline)。
用模式匹配对Empty 做了特别处理，使得在一个Doc 的左边或右边接一个Empty 没有任何效果，以防止tree 因无用的值而膨胀。
可以说Empty 是concatenation 的单位元，类似于0 是加法的单位元，1 是乘法的单位元。
{-
ghci> text "foo" <> text "bar"
Concat (Text "foo") (Text "bar")
ghci> text "foo" <> empty
Text "foo"
ghci> empty <> text "bar"
Text "bar"
-}
hcat 和fsep 函数将一列表的Doc (子树)连接成一个Doc。
回想一下我们是如何定义list 的concatenation 的。
{-
concat :: [[a]] -> [a]
concat = foldr (++) []
-}
因为(<>) 类似于(++)，而Empty 类似于([])，这提示我们如何用folds 来实现hcat 和fsep。
{-
hcat :: [Doc] -> Doc
hcat = fold (<>)
fold :: (Doc -> Doc -> Doc) -> [Doc] -> Doc
fold f = foldr f empty -- 亮点
-}
fsep 的定义依赖于其它一些函数
{-
fsep :: [Doc] -> Doc
fsep = fold (</>)
(</>) :: Doc -> Doc -> Doc
x </> y = x <> softline <> y
softline :: Doc
softline = group line
-}
softline 函数会插入一个新行，如果当前行变得过宽，否则就插入一个空格。如何做到这一点？如果Doc 类型不包含任何关于rendering 的信息。答案是，每一次遇到软换行，我们使用Union 构造器维护文档的两个可选表示。
{-
group :: Doc -> Doc
group x = flatten x `Union` x
-}
flatten 函数将一个line 替换成一个空格，将两行转成一个更长的行。
{-
flatten :: Doc -> Doc
flatten (x `Concat` y) = flatten x `Concat` flatten y
flatten Line = Char ' '
flatten (x `Union` _) = flatten x
flatten other = other
-}
注意到我们总是调用flatten 在Union 的左元素：每个Union 的左元素总是有相同的宽度(in characters)，或比右边宽。
Compact Rendering
-- Prettify.hs
{-
compact :: Doc -> String
compact x = transform [x] -- 亮点 -- 注意这里是怎样将参数装进list 里面的
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)
-}
compact 将其参数包装进一个list 里面，并对它应用辅助函数transform。transform 函数将其参数看成一个items 的stack 来处理，list 中的第一个元素就是stack 的top。
{-
ghci> let value = renderJValue (JObject [("f", JNumber 1), ("q", JBool True)])
ghci> :type value
value :: Doc
ghci> putStrLn (compact value)
{"f": 1.0,
"q": true
}
-}
renderJValue (JObject [("f", JNumber 1), ("q", JBool True)])
compact value -- 用print 打印不知道为什么出错
compact (char 'f' <> text "oo") -- "foo"
True Pretty Printing
compact 对机器到机器的通信有用，但是其结果不总是易读的：每一行的信息非常少。为生成更可读的输出，我们将编写另一个函数，pretty 函数。相比compact ，pretty 接受一个额外的参数：一行的最大宽度，列数（假定typeface 是固定宽度）：
{-
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
-}
pretty 的Int 参数控制其遇到软件换行softline 时的行为。只有在softline 这里pretty 有可选的行为，它或继续当前行，或开始新的一行。
{-
fits :: Int -> String -> Bool
w `fits` _ | w < 0 = False
w `fits` "" = True
w `fits` ('/n':_) = True
w `fits` (c:cs) = (w - 1) `fits` cs
-}
Following the Pretty Printer
ghci> empty </> char 'a'
Concat (Union (Char ' ') Line) (Char 'a')
ghci> 2 `fits` " a"
True
ghci> putStrLn (pretty 10 value)
{"f": 1.0,
"q": true
}
ghci> putStrLn (pretty 20 value)
{"f": 1.0, "q": true
}
ghci> putStrLn (pretty 30 value)
{"f": 1.0, "q": true }
Creating a Package
Haskell 社区创建了一个名为Cabal 的标准工具集，可以帮助我们创建，安装，和分发软件。Cabal 将软件组织为包的形式。一个包含一个库，并且可能有几个可执行程序。
Writing a Package Description
要使用包，Cabal 需要对它的一个描述，就是一个后缀为.cabal 的文本文件。这个文件位于project 的顶级目录中。它具有简单的格式。
{-
Cabal-Version: >= 1.2 -- 要求Cabal 的版本不低于1.2
library
Exposed-Modules: Prettify
PrettyJSON
JSON
Build-Depends: base >= 2.0 -- base 包含很多Haskell 核心模块，如Prelude，所以几乎总是需要的。
-}
Exposed-Modules 包含要导出让用户可见的模块。有一个可选域，Other-Modules，表示内部模块需要用到，但用户不可见的模块。
GHC’s Package Manager
GHC 包含一个简单的包管理器，它tracks 一个包的安装，包的版本是什么。命令行工具ghc-pkg 让我们可以操作其包数据库。
ghc-pkg list 命令会列出已安装的包。命令ghc-pkg unregister 用于卸载包(已安装的文件需要手工删除)。
Setting Up, Building, and Installing
一个包除了有.cabal 文件，还必须要有一个安装文件。
典型的安装文件像这样：
{-
Setup.hs
#!/usr/bin/env runhaskell
import Distribution.Simple
main = defaultMain
-}
一旦写好了.cabal 和Steup.hs 文件，这儿还有三件事要做：
1. 指导Cabal 如何创建和在包要安装在哪里，远行一个简单命令：
$ runghc Setup configure
这个保证我们需要的包是可用的，还有其存储的settings 对稍后其它Cabal 命令也可用。
如果不给configure 提供任何参数，Cabal 将我们的包安装在系统范围包数据库。
2. build 这个包
$ runghc Setup build
3. 如果这一步成功，我们可以安装这个包。我们不需要去指出安装在哪里——Cabal 将使用我们在configure 那一步中提供的settings。它将安装在我们自已的目录，并更新GHC 的per-user 包数据库。
Practical Pointers and Further Reading
GHC 已经提供了一个名为Text.PrettyPrint.HughesPJ 的pretty-printing 库。建议使用它，而不是自已去写。
pretty-printing 库的设计文档可以在这里找到(http://citeseer.ist.psu.edu/hughes95design.html)
------------------------------------------------------------------------------------------------
-- 本章的代码
--Setup.bat
Setup.hs
import Distribution.Simple
main = defaultMain
-------------------------------------------------
-- Setup.hs
import Distribution.Simple
main = defaultMain
-------------------------------------------------
-- mypretty.cabal
Name: mypretty
Version: 0.1
Synopsis: My pretty printing library, with JSON support
Description:
A simple pretty-printing library that illustrates how to
develop a Haskell library.
Author: Real World Haskell
Maintainer: nobody@realworldhaskell.org
Cabal-Version: >= 1.2
library
Exposed-Modules: Prettify
PrettyJSON
JSON
Build-Depends: base >= 2.0
---------------------------------------------------------
-- JSON.hs
-- 定义模块的方法
module JSON
(
JValue(..)
, getString
, getInt
, getDouble
, getBool
, getObject
, getArray
, isNull
) where
-- module 后接模块名，模块名必须以大写字母开头。源文件名和模块名必须相同。
-- 模块名后接导出列表，where 关键字指出后面follow 模块体。
-- 导出列表指出此模块中的哪些名字在其它模块中可见。
-- JValue 后面的特殊notation “(..)” 表示导出type 和所有构造器。
-- 如果忽略导出列表及包围它的括号“()”，则会导出模块中的所有名字
-- module ExportEverything where
-- 如果想要不导出任何名字（这样几乎没什么用），可以让导出列表为空。
-- module ExportNothing () 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 (JNumber n) = Just (truncate n)
getInt _ = Nothing
getDouble (JNumber n) = Just n
getDouble _ = Nothing
getBool (JBool b) = Just b
getBool _ = Nothing
getObject (JObject o) = Just o
getObject _ = Nothing
getArray (JArray a) = Just a
getArray _ = Nothing
isNull v = v == JNull
---------------------------------------------------------------------------------
-- Prettify.hs
module Prettify
(
-- * Constructors
Doc
-- * Basic combinators
, (<>)
, empty
, char
, text
, line
-- * Derived combinators
, double
, fsep
, hcat
, punctuate
-- * Renderers
, compact
, pretty
) where
punctuate :: Doc -> [Doc] -> [Doc]
punctuate p [] = []
punctuate p [d] = [d]
punctuate p (d:ds) = (d <> p) : punctuate p ds
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 <> y = y
x <> Empty = x
x <> y = x `Concat` y
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
--------------------------------------------------------------------------------
-- PrettyJSON.hs
module PrettyJSON
(
renderJValue
,simpleEscapes
) where
--import JSON
import Numeric (showHex)
import Data.Char (ord)
import Data.Bits (shiftR, (.&.))
import JSON (JValue(..))
import Prettify (Doc, (<>), char, double, fsep, hcat, punctuate, text,
compact, pretty)
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'
-- case 表达式检查一个字符是否匹配alist 中的元素。如果成功匹配就emit 它，否则就需要将它escape 成更复杂的形式。
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 ""
-- 更复杂的escaping 涉及将一个字符转成以"/u" 开头，后接四个十六进制数字，以此来表示Unicode 字符。
-- showHex 函数返回一个数的十六进制表示(需要引入Numeric 库)。
{-
ghci> showHex 114111 ""
"1bdbf"
-}
-- replicate 函数将输入参数复制指定次数并装在list 中返回
{-
ghci> replicate 5 "foo"
["foo","foo","foo","foo","foo"]
-}
astral :: Int -> Doc
astral n = smallHex (a + 0xd800) <> smallHex (b + 0xdc00)
where a = (n `shiftR` 10) .&. 0x3ff
b = n .&. 0x3ff
-- smallHex 函数有个缺陷，它表示的字符冲顶只到0xffff，而Unicode 的最大有效值是0x10ffff。
-- 为了正确表示大于0xffff 的JOSON 字符，我们用一些复杂的规则将超过0xffff 的字符分割成两部分。这给了我们一个在比特级上操作Haskel 数字的机会。
-- shiftR 和“.&.” 在Data.Bits 模块
{-
ghci> 0x10000 `shiftR` 4 :: Int
4096
ghci> 7 .&. 2 :: Int
2
-}
hexEscape :: Char -> Doc
hexEscape c | d < 0x10000 = smallHex d
| otherwise = astral (d - 0x10000)
where d = ord c
-- Arrays and Objects, and the Module Header
series :: Char -> Char -> (a -> Doc) -> [a] -> Doc
series open close item = enclose open close
. fsep . punctuate (char ',') . map item
-- 注意到虽然我们的类型签名要求的参数是四个，但是我们在函数定义处只列出三个。这种规则可以让我们简化函数定义，例如myLength xs = length xs 可以简化为myLength = length
-- PrettyStub.hs
{-
fsep :: [Doc] -> Doc
fsep xs = undefined
-}
-- fsep 函数将一个Doc 列表combines 成一个Doc。可能到lines 做些包装，如果输出不适合单行。
--punctuate :: Doc -> [Doc] -> [Doc]
--punctuate p [] = []
--punctuate p [d] = [d]
--punctuate p (d:ds) = (d <> p) : punctuate p ds
renderJValue (JArray ary) = series '[' ']' renderJValue ary
renderJValue (JObject obj) = series '{' '}' field obj
where field (name,val) = string name
<> text ": "
<> renderJValue val
扫一扫
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
