Prettify.hs

module Prettify
  ( 
    Doc,
    char, double, text, 
    (<>), hcat, fsep, punctuate,
    compact, pretty
  ) where

data Doc = Empty
         | Char Char
         | Text String    
         | Line           -- line break
         | Concat Doc Doc -- two docs concatenated
         | Union  Doc Doc -- second doc will be <spaces>
  deriving Show

----------------------------------------

double :: Double -> Doc
double = Text . show

char :: Char -> Doc
char = Char

text :: String -> Doc
text "" = Empty
text t  = Text t

---------------------------------------

(<>) :: Doc -> Doc -> Doc
Empty <> x = x
x <> Empty = x
x <> y     = Concat x y

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

-- flattens new line to a space
flatten :: Doc -> Doc
flatten (Concat x y) = flatten x <> flatten y
flatten Line         = Char ' '
flatten (Union x _)  = flatten x
flatten other        = other

union :: Doc -> Doc
union x = flatten x `Union` x

softLine :: Doc
softLine = union Line

fold :: (Doc -> Doc -> Doc) -> [Doc] -> Doc
fold f = foldr f Empty

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

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

punctuate :: Doc -> [Doc] -> [Doc]
punctuate p []     = []
punctuate p [d]    = [d]
punctuate p (d:ds) = (d<>p) : punctuate p ds

-------------------------------------------------------

compact :: Doc -> String
compact x = transform [x]
  where transform []     = ""
        transform (d:ds) = case d of
          Empty       -> transform ds
          Line        -> '\n' :  transform ds
          Char c      -> c    :  transform ds
          Text t      -> t    ++ transform ds
          Concat x y  -> transform (x:y:ds)
          Union _ y   -> transform (  y:ds)

pretty :: Int -> Doc -> String
pretty width x = best 0 [x]
  where best col (d:ds) = case d of
          Empty -> best col ds
          Line  -> '\n' :  best 0                ds
          Char c -> c   :  best (col+1)          ds
          Text t -> t   ++ best (col + length t) ds
          Concat x y -> best   col (x:y:ds)
          Union  x y -> nicest col (best col (x:ds))
                                   (best col (y:ds))
        best _ _ = ""
        nicest col a b | (width - least) `fits` a = a
                       | otherwise                = b
          where least = min width col
                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
  ) where

import Prettify (Doc, (<>), char, double, fsep, hcat, punctuate, text
                ,compact, pretty)
import SimpleJSON (JValue(..))

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

value :: Doc
value = renderJValue (JObject [("f", JNumber 1), ("q", JBool True)])

renderJValue :: JValue -> Doc
renderJValue (JString s)   = string s
renderJValue (JNumber n)   = double n
renderJValue (JBool True)  = text "true"
renderJValue (JBool False) = text "false"
renderJValue JNull         = text "null"
renderJValue (JArray a)    = series '[' ']' renderJValue a
renderJValue (JObject o)   = series '{' '}' renderJField o
  where renderJField (k,v) = string k
                          <> text ": "
                          <> renderJValue v

-- --------------------------------------------------------

string :: String -> Doc
string = enclose '"' '"' . hcat . map oneChar

enclose :: Char -> Char -> Doc -> Doc
enclose l r x = char l <> x <> char r

-- ********************************************************
-- CHAR ---------------------------------------------------
-- ********************************************************

smallHex :: Int -> Doc
smallHex i = text "\\u"
          <> text (replicate (4-length h) '0')
          <> text h
  where h = showHex i ""

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

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]) 


-- ********************************************************
-- OBJECTS AND ARRAYS -------------------------------------
-- ********************************************************

series :: Char -> Char -> (a -> Doc) -> [a] -> Doc
series open close fItem = enclose open close . fsep 
                        . punctuate (char ',') . map fItem

PutJSON.hs

-- pojednostavljeno

module PutJSON 
  (
    renderJValue
  ) where

import Data.List (intercalate)
import SimpleJSON

renderJValue :: JValue -> String
renderJValue (JString s)   = 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) = k ++ ": " ++ renderJValue v

renderJValue (JArray a) = "[" ++ values a ++ "]"
  where values [] = ""
        values js = intercalate ", " . map renderJValue $ js


putValue :: JValue -> IO ()
putValue = putStrLn . renderJValue

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 (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 JNull = True
isNull _     = False