ch05: Copy needed files from the examples

3 files changed, 296 insertions, 0 deletions

diff --git a/ch05/Prettify.hs b/ch05/Prettify.hs
new file mode 100644
index 0000000..7b3ea10
--- /dev/null
+++ b/ch05/Prettify.hs
@@ -0,0 +1,160 @@
+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
diff --git a/ch05/PrettyJSON.hs b/ch05/PrettyJSON.hs
new file mode 100644
index 0000000..d9d7579
--- /dev/null
+++ b/ch05/PrettyJSON.hs
@@ -0,0 +1,88 @@
+{-- 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 --}
diff --git a/ch05/SimpleJSON.hs b/ch05/SimpleJSON.hs
new file mode 100644
index 0000000..d692168
--- /dev/null
+++ b/ch05/SimpleJSON.hs
@@ -0,0 +1,48 @@
+{-- 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 --}