diff options
| -rw-r--r-- | ch05/Prettify.hs | 160 | ||||
| -rw-r--r-- | ch05/PrettyJSON.hs | 88 | ||||
| -rw-r--r-- | ch05/SimpleJSON.hs | 48 |
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 --} |