Real World Haskell - 第5章 Part3 A more general look at rendering 〜 Practical pointers and further reading

Haskell プログラミング

Real World Haskell で Haskell を継続的に勉強中。


Chapter 5. Writing a library: working with JSON data
Chapter 5. Writing a library: working with JSON data

A more general look at rendering

  • Prettify module つくるよ

Developing Haskell code without going nuts

  • undefined は stub を書くのに便利
string :: String -> Doc
string str = undefined

Pretty printing a string

  • 文字通り、pretty printing な話
    • escape とか hex とか
    • showHex, shiftR, ord

Arrays and objects, and the module header

  • 引き続き array などの pretty printing

Writing a module header

  • import でも明示的にリストを書く方が良い
    • どこから何を import しているのかが分かりやすい
    • import しているものが remove/rename された場合にすぐ分かる
    • 重複した名前でのエラーを防げる

Fleshing out the pretty printing library 〜 Following the pretty printer

  • 実装、実装、実装

Creating a package

  • Haskell には Cabal というパッケージシステムがある
    • パッケージを作るにはプログラム本体以外に .cabal ファイルが必要
      • パッケージ名、バージョン、ライセンス、依存関係などを記述する

GHC's package manager

  • ghc-pkg でパッケージデータベースについて操作できる

Setting up, building, and installing

  • パッケージは Setup.hs でセットアッププロセスをカスタマイズ可能
    • シンプルなものはこんな感じ
#!/usr/bin/env runhaskell
import Distribution.Simple
main = defaultMain
  • インストール手順の例

$ runghc Setup configure
$ runghc Setup build
$ runghc Setup install

Practical pointers and further reading

最終的なコード

{-- snippet module --}
module PrettyJSON
    (
      renderJValue
    ) where

import Numeric (showHex)
import Data.Char (ord)
import Data.Bits (shiftR, (.&.))

import SimpleJSON (JValue(..))
import Prettify (Doc, (<>), char, double, fsep, hcat, punctuate, text,
                 compact, pretty)
{-- /snippet module --}

{-- snippet renderJValue --}
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
{-- /snippet renderJValue --}
{-- snippet renderJValue.array --}
renderJValue (JArray ary) = series '[' ']' renderJValue ary
{-- /snippet renderJValue.array --}
{-- snippet renderJValue.object --}
renderJValue (JObject obj) = series '{' '}' field obj
    where field (name,val) = string name
                          <> text ": "
                          <> renderJValue val
{-- /snippet renderJValue.object --}

{-- snippet enclose --}
enclose :: Char -> Char -> Doc -> Doc
enclose left right x = char left <> x <> char right
{-- /snippet enclose --}

{-- snippet hexEscape --}
hexEscape :: Char -> Doc
hexEscape c | d < 0x10000 = smallHex d
            | otherwise   = astral (d - 0x10000)
  where d = ord c
{-- /snippet hexEscape --}

{-- snippet smallHex --}
smallHex :: Int -> Doc
smallHex x  = text "\\u"
           <> text (replicate (4 - length h) '0')
           <> text h
    where h = showHex x ""
{-- /snippet smallHex --}

{-- snippet astral --}
astral :: Int -> Doc
astral n = smallHex (a + 0xd800) <> smallHex (b + 0xdc00)
    where a = (n `shiftR` 10) .&. 0x3ff
          b = n .&. 0x3ff
{-- /snippet astral --}

{-- snippet string --}
string :: String -> Doc
string = enclose '"' '"' . hcat . map oneChar
{-- /snippet string --}

{-- snippet pointyString --}
pointyString :: String -> Doc
pointyString s = enclose '"' '"' (hcat (map oneChar s))
{-- /snippet pointyString --}

{-- snippet oneChar --}
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])
{-- /snippet oneChar --}

{-- snippet series --}
series :: Char -> Char -> (a -> Doc) -> [a] -> Doc
series open close item = enclose open close
                       . fsep . punctuate (char ',') . map item
{-- /snippet series --}

{-- snippet module --}
module SimpleJSON
    (
      JValue(..)
    , getString
    , getInt
    , getDouble
    , getBool
    , getObject
    , getArray
    , isNull
    ) where
{-- /snippet module --}

{-- snippet JValue --}
data JValue = JString String
            | JNumber Double
            | JBool Bool
            | JNull
            | JObject [(String, JValue)]
            | JArray [JValue]
              deriving (Eq, Ord, Show)
{-- /snippet JValue --}

{-- snippet getString --}
getString :: JValue -> Maybe String
getString (JString s) = Just s
getString _           = Nothing
{-- /snippet getString --}

{-- snippet getters --}
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
{-- /snippet getters --}

module Prettify
    (
    -- * Constructors
      Doc
    -- * Basic combinators
    , (<>)
    , empty
    , char
    , text
    , line
    -- * Derived combinators
    , double
    , fsep
    , hcat
    , punctuate
    -- * Renderers
    , compact
    , pretty
    ) where

{--
import Data.Monoid (Monoid(..))

instance Monoid Doc where
    mempty = empty
    mappend = (<>)
--}

{-- snippet Doc --}
data Doc = Empty
         | Char Char
         | Text String
         | Line
         | Concat Doc Doc
         | Union Doc Doc
           deriving (Show,Eq)
{-- /snippet Doc --}

{-- snippet append --}
(<>) :: Doc -> Doc -> Doc
Empty <> y = y
x <> Empty = x
x <> y = x `Concat` y
{-- /snippet append --}

{-- snippet basic --}
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)
{-- /snippet basic --}

{-- snippet line --}
line :: Doc
line = Line
{-- /snippet line --}

{-- snippet hcat --}
hcat :: [Doc] -> Doc
hcat = fold (<>)

fold :: (Doc -> Doc -> Doc) -> [Doc] -> Doc
fold f = foldr f empty
{-- /snippet hcat --}

{-- snippet fsep --}
fsep :: [Doc] -> Doc
fsep = fold (</>)

(</>) :: Doc -> Doc -> Doc
x </> y = x <> softline <> y

softline :: Doc
softline = group line
{-- /snippet fsep --}

{-- snippet group --}
group :: Doc -> Doc
group x = flatten x `Union` x
{-- /snippet group --}

{-- snippet flatten --}
flatten :: Doc -> Doc
flatten (x `Concat` y) = flatten x `Concat` flatten y
flatten Line           = Char ' '
flatten (x `Union` _)  = flatten x
flatten other          = other
{-- /snippet flatten --}

{-- snippet punctuate --}
punctuate :: Doc -> [Doc] -> [Doc]
punctuate p []     = []
punctuate p [d]    = [d]
punctuate p (d:ds) = (d <> p) : punctuate p ds
{-- /snippet punctuate --}

{-- snippet compact --}
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)
{-- /snippet compact --}

{-- snippet pretty.type --}
pretty :: Int -> Doc -> String
{-- /snippet pretty.type --}

{-- snippet pretty --}
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
{-- /snippet pretty --}

{-- snippet fits --}
fits :: Int -> String -> Bool
w `fits` _ | w < 0 = False
w `fits` ""        = True
w `fits` ('\n':_)  = True
w `fits` (c:cs)    = (w - 1) `fits` cs
{-- /snippet fits --}

{-- snippet nest --}
nest :: Int -> Doc -> Doc
{-- /snippet nest --}
nest = undefined

{-- snippet fill --}
fill :: Int -> Doc -> Doc
{-- /snippet fill --}
fill = undefined

--instance Show Doc where
--    show doc = pretty 80 doc