{-# LANGUAGE FlexibleInstances,TypeSynonymInstances #-}

import JSONClass
import Numeric
import Control.Applicative
import Control.Monad (MonadPlus(..), ap)
import Text.ParserCombinators.Parsec hiding (many, optional, (<|>))

p_text :: CharParser () JValue
p_text = spaces *> text <?> "JSON text"
    where text = JObject <$> p_object
             <|> JArray <$> p_array

p_series :: Char -> CharParser () a -> Char -> CharParser () [a]
p_series left parser right =
    between (char left <* spaces) (char right) $
            (parser <* spaces) `sepBy` (char ',' <* spaces)

p_array :: CharParser () (JAry JValue)
p_array = JAry <$> p_series '[' p_value ']'

p_object :: CharParser () (JObj JValue)
p_object = JObj <$> p_series '{' p_field '}'
    where p_field = (,) <$> (p_string <* char ':' <* spaces) <*> p_value

p_value :: CharParser () JValue
p_value = value <* spaces
    where value = JString <$> p_string
              <|> JNumber <$> p_number
              <|> JObject <$> p_object
              <|> JArray <$> p_array
              <|> JBool <$> p_bool
              <|> JNull <$ string "null"
              <?> "JSON value"

p_bool :: CharParser () Bool
p_bool = True <$ string "true" <|> False <$ string "false"

p_value_choice = value <* spaces
    where value = choice [ JString <$> p_string
                         , JNumber <$> p_number
                         , JObject <$> p_object
                         , JArray <$> p_array
                         , JBool <$> p_bool
                         , JNull <$  string "null"
                         ]
                  <?> "JSON value"

p_number :: CharParser () Double
p_number = do s <- getInput
              case readSigned readFloat s of
                [(n, s')] -> n <$ setInput s'
                _ -> empty

p_string :: CharParser () String
p_string = between (char '\"') (char '\"') (many jchar)
    where jchar = char '\\' *> (p_escape <|> p_unicode)
              <|> satisfy (`notElem` "\"\\")

p_escape = choice (zipWith decode "bnfrt\\\"/" "\b\n\f\r\t\\\"/")
    where decode c r = r <$ char c

p_unicode :: CharParser () Char
p_unicode = char 'u' *> (decode <$> count 4 hexDigit)
    where decode x = toEnum code
              where ((code,_):_) = readHex x

*Main> parse p_text "(unknown)" "[1,2,3]"
Right (JArray (JAry {fromJAry = [JNumber 1.0,JNumber 2.0,JNumber 3.0]}))
*Main> parse p_text "(unknown)" "{\"test\":3}"
Right (JObject (JObj {fromJObj = [("test",JNumber 3.0)]}))

instance (JSON a) => JSON [a] where
    toJValue = undefined
    fromJValue = undefined

instance (JSON a) => JSON [(String, a)] where
    toJValue = undefined
    fromJValue = undefined

instance (JSON a) => JSON (JObj a) where
    toJValue = JObject . JObj . map (second toJValue) . fromJObj
    fromJValue (JObject (JObj o)) = whenRight JObj (mapEithers unwrap o)
        where unwrap (k,v) = whenRight ((,) k) (fromJValue v)
    fromJValue _ = Left "not a JSON object"

instance (JSON a) => JSON (JAry a) where
    toJValue = jaryToJValue
    fromJValue = jaryFromJValue

newtype JAry a = JAry {
      fromJAry :: [a]
    } deriving (Eq, Ord, Show)

newtype JObj a = JObj {
      fromJObj :: [(String, a)]
    } deriving (Eq, Ord, Show)

*JSONClass> toJValue . JObj $ [("test", 1)]
JObject (JObj {fromJObj = [("test",JNumber 1.0)]})
*JSONClass> toJValue . JAry $ [1,2,3]
JArray (JAry {fromJAry = [JNumber 1.0,JNumber 2.0,JNumber 3.0]})

Prelude> :t (,)
(,) :: a -> b -> (a, b)
Prelude> (,) 'a' 'b'
('a','b')

Prelude> 'a' , 'b'

<interactive>:33:5: parse error on input `,'

Prelude> :i (,)
data (,) a b = (,) a b  -- Defined in `GHC.Tuple'
instance (Bounded a, Bounded b) => Bounded (a, b)
  -- Defined in `GHC.Enum'
instance (Eq a, Eq b) => Eq (a, b) -- Defined in `GHC.Classes'
instance (Ord a, Ord b) => Ord (a, b) -- Defined in `GHC.Classes'
instance (Read a, Read b) => Read (a, b) -- Defined in `GHC.Read'
instance (Show a, Show b) => Show (a, b) -- Defined in `GHC.Show'

fact 0 = return 1
fact n = do
  print n
  n1 <- fact (n-1)
  return (n * n1)

import Control.Monad.Writer

factT :: Int -> WriterT [Int] IO Int
factT 0 = tell [0] >> return 1
factT n = do
  tell [n]
  n1 <- factT (pred n)

*Main> runWriterT $ factT 5
(120,[5,4,3,2,1,0])
*Main> execWriterT $ factT 5
[5,4,3,2,1,0]
*Main> liftM fst $ runWriterT $ factT 5
120

instance (Monoid w, Monad m) => Monad (WriterT w m) where
    return a = WriterT $ return (a, mempty)
    m >>= k  = WriterT $ do
        (a, w)  <- runWriterT m
        (b, w') <- runWriterT (k a)
        return (b, w `mappend` w')
    fail msg = WriterT $ fail msg

import Control.Monad.Writer

factW :: Int -> Writer [Int] Int
factW 0 = tell [0] >> return 1
factW n = do
  tell [n]
  n1 <- factW (pred n)
  return $ n * n1

*Main> runWriter $ factW 5
(120,[5,4,3,2,1,0])