json-parser.hs

{-# LANGUAGE OverloadedStrings #-}

module Main where

import Data.Char
import Control.Applicative (Alternative(..))
import qualified Data.Map as Map
import qualified Data.Text as T

-- JSON数据类型定义
data JSONValue
  = JNull
  | JBool Bool
  | JNumber Double
  | JString T.Text
  | JArray [JSONValue]
  | JObject (Map.Map T.Text JSONValue)
  deriving (Eq, Show)

-- 解析器类型
newtype Parser a = Parser { runParser :: String -> Maybe (a, String) }

-- 解析器实例
instance Functor Parser where
  fmap f p = Parser $ \s -> do
    (x, s') <- runParser p s
    return (f x, s')

instance Applicative Parser where
  pure x = Parser $ \s -> Just (x, s)
  pf <*> px = Parser $ \s -> do
    (f, s') <- runParser pf s
    (x, s'') <- runParser px s'
    return (f x, s'')

instance Alternative Parser where
  empty = Parser $ \_ -> Nothing
  p1 <|> p2 = Parser $ \s -> runParser p1 s <|> runParser p2 s

-- 添加 Monad 实例
instance Monad Parser where
  p >>= f = Parser $ \s -> do
    (x, s') <- runParser p s
    runParser (f x) s'

-- 添加 MonadFail 实例
instance MonadFail Parser where
  fail _ = Parser $ \_ -> Nothing

-- 基本解析器
char :: Char -> Parser Char
char c = satisfy (== c)

satisfy :: (Char -> Bool) -> Parser Char
satisfy pred = Parser $ \s -> case s of
  (c:cs) | pred c -> Just (c, cs)
  _ -> Nothing

string :: String -> Parser String
string = traverse char

-- 辅助函数 - 重命名避免冲突
many' :: Parser a -> Parser [a]
many' p = some' p <|> pure []

some' :: Parser a -> Parser [a]
some' p = (:) <$> p <*> many' p

option :: a -> Parser a -> Parser a
option x p = p <|> pure x

-- 空白字符解析
space :: Parser ()
space = many' (satisfy isSpace) *> pure ()

-- 基本JSON值解析
parseNull :: Parser JSONValue
parseNull = string "null" *> pure JNull

parseBool :: Parser JSONValue
parseBool = (string "true" *> pure (JBool True))
        <|> (string "false" *> pure (JBool False))

-- 增强版数字解析（支持负数和浮点数）
parseNumber :: Parser JSONValue
parseNumber = JNumber . read <$> parseNumberString
  where
    parseNumberString = do
      sign <- option "" (string "-")
      intPart <- some' (satisfy isDigit)
      let fracPartTemp = option "" (char '.' *> some' (satisfy isDigit))
      fracPart <- fracPartTemp
      let expPartTemp = option "" parseExponent
      expPart <- expPartTemp
      return (sign ++ intPart ++ fracPart ++ expPart)
    
    parseExponent = do
      _ <- char 'e' <|> char 'E'
      expSign <- option "" (string "+" <|> string "-")
      expDigits <- some' (satisfy isDigit)
      return ('e' : expSign ++ expDigits)

-- 增强版字符串解析（支持转义字符）
parseString :: Parser JSONValue
parseString = JString . T.pack <$> (char '"' *> parseStringContent <* char '"')
  where
    parseStringContent = many' (parseChar <|> parseEscape)
    
    parseChar = satisfy (\c -> c /= '"' && c /= '\\')
    
    parseEscape = do
      _ <- char '\\'
      c <- satisfy (`elem` ['\"', '\\', '/', 'b', 'f', 'n', 'r', 't'])
      return $ case c of
        'b' -> '\b'
        'f' -> '\f'
        'n' -> '\n'
        'r' -> '\r'
        't' -> '\t'
        _ -> c

parseArray :: Parser JSONValue
parseArray = JArray <$> (char '[' *> space *> (parseValues <|> pure []) <* space <* char ']')
  where
    parseValues = do
      first <- parseValue
      rest <- many' (space *> char ',' *> space *> parseValue)
      return (first : rest)

parseObject :: Parser JSONValue
parseObject = JObject . Map.fromList <$> (char '{' *> space *> (parsePairs <|> pure []) <* space <* char '}')
  where
    parsePairs = do
      first <- parsePair
      rest <- many' (space *> char ',' *> space *> parsePair)
      return (first : rest)
    
    parsePair = do
      strVal <- parseString
      case strVal of
        JString key -> do
          space
          _ <- char ':'
          space
          value <- parseValue
          return (key, value)
        _ -> fail "Expected string key in object"

-- 主要解析函数
parseValue :: Parser JSONValue
parseValue = space *> (parseNull
                  <|> parseBool
                  <|> parseNumber
                  <|> parseString
                  <|> parseArray
                  <|> parseObject)
             <* space

-- 导出函数
parseJSON :: String -> Maybe JSONValue
parseJSON s = case runParser parseValue s of
  Just (result, "") -> Just result
  _ -> Nothing

-- 美化打印JSON
prettyPrint :: JSONValue -> String
prettyPrint = go 0
  where
    go indent value = case value of
      JNull -> "null"
      JBool True -> "true"
      JBool False -> "false"
      JNumber n -> show n
      JString s -> "\"" ++ T.unpack s ++ "\""
      JArray arr -> "[" ++ goArray indent arr ++ "]"
      JObject obj -> "{" ++ goObject indent (Map.toList obj) ++ "}"
    
    goArray indent arr = case arr of
      [] -> ""
      [x] -> go (indent + 2) x
      (x:xs) -> go (indent + 2) x ++ ", " ++ goArray indent xs
    
    goObject indent pairs = case pairs of
      [] -> ""
      [(k,v)] -> "\"" ++ T.unpack k ++ "\": " ++ go (indent + 2) v
      ((k,v):xs) -> "\"" ++ T.unpack k ++ "\": " ++ go (indent + 2) v ++ ", " ++ goObject indent xs

-- 从JSON中提取数据的辅助函数
extractString :: JSONValue -> Maybe String
extractString (JString s) = Just (T.unpack s)
extractString _ = Nothing

extractNumber :: JSONValue -> Maybe Double
extractNumber (JNumber n) = Just n
extractNumber _ = Nothing

extractBool :: JSONValue -> Maybe Bool
extractBool (JBool b) = Just b
extractBool _ = Nothing

getFromObject :: T.Text -> JSONValue -> Maybe JSONValue
getFromObject key (JObject obj) = Map.lookup key obj
getFromObject _ _ = Nothing

-- 测试函数
testJSON :: IO ()
testJSON = do
  -- 测试用例
  let test1 = "null"
  let test2 = "true"
  let test3 = "false"
  let test4 = "123"
  let test5 = "-456"
  let test6 = "3.14"
  let test7 = "-2.5e-10"
  let test8 = "\"hello\\nworld\""
  let test9 = "[1,2,3]"
  let test10 = "[1, \"two\", true, null]"
  let test11 = "{\"name\":\"John\",\"age\":30}"
  let test12 = "{\"person\":{\"name\":\"Alice\",\"age\":25},\"active\":true}"
  let test13 = "{\n  \"name\": \"Bob\",\n  \"hobbies\": [\"reading\", \"swimming\"]\n}"
  
  putStrLn "=== JSON Parser Test Results ===\n"
  
  let tests = [("null", test1), ("true", test2), ("false", test3),
               ("positive int", test4), ("negative int", test5),
               ("float", test6), ("scientific", test7),
               ("escaped string", test8), ("array", test9),
               ("mixed array", test10), ("object", test11),
               ("nested object", test12), ("formatted", test13)]
  
  mapM_ (\(name, input) -> do
    putStrLn $ "Test: " ++ name
    putStrLn $ "Input: " ++ input
    case parseJSON input of
      Just result -> do
        putStrLn $ "Parsed: " ++ show result
        putStrLn $ "Pretty: " ++ prettyPrint result
      Nothing -> putStrLn "Parse failed"
    putStrLn "") tests

-- 实际应用示例
exampleUsage :: IO ()
exampleUsage = do
  putStrLn "\n=== Usage Examples ===\n"
  
  -- 示例1：解析配置文件
  let configJson = "{\"host\":\"localhost\",\"port\":8080,\"debug\":true}"
  case parseJSON configJson of
    Just (JObject config) -> do
      putStrLn "Configuration loaded:"
      let host = Map.lookup "host" config >>= extractString
      let port = Map.lookup "port" config >>= extractNumber
      let debug = Map.lookup "debug" config >>= extractBool
      putStrLn $ "Host: " ++ show host
      putStrLn $ "Port: " ++ show port
      putStrLn $ "Debug: " ++ show debug
    _ -> putStrLn "Failed to parse config"
  
  putStrLn ""
  
  -- 示例2：解析API响应
  let apiResponse = "{\"status\":\"success\",\"data\":{\"id\":123,\"name\":\"Product\"}}"
  case parseJSON apiResponse of
    Just (JObject response) -> do
      let status = Map.lookup "status" response >>= extractString
      let dataObj = Map.lookup "data" response
      putStrLn $ "API Status: " ++ show status
      case dataObj of
        Just (JObject dataContent) -> do
          let id = Map.lookup "id" dataContent >>= extractNumber
          let name = Map.lookup "name" dataContent >>= extractString
          putStrLn $ "Product ID: " ++ show id
          putStrLn $ "Product Name: " ++ show name
        _ -> putStrLn "No data found"
    _ -> putStrLn "Failed to parse API response"
  
  putStrLn ""
  
  -- 示例3：处理嵌套数组
  let matrixJson = "[[1,2,3],[4,5,6],[7,8,9]]"
  case parseJSON matrixJson of
    Just (JArray matrix) -> do
      putStrLn "Matrix:"
      mapM_ (putStrLn . ("  " ++) . prettyPrint) matrix
    _ -> putStrLn "Failed to parse matrix"

-- 错误处理版本（返回错误信息）
parseJSONWithError :: String -> Either String JSONValue
parseJSONWithError s = case runParser parseValue s of
  Just (result, "") -> Right result
  Just (_, rest) -> Left $ "Leftover input: " ++ rest
  Nothing -> Left "Parse error"

-- 批量解析
parseMultipleJSON :: [String] -> [Maybe JSONValue]
parseMultipleJSON = map parseJSON

-- 主函数
main :: IO ()
main = do
  testJSON
  exampleUsage
  
  putStrLn "\n=== Error Handling Example ===\n"
  let invalidJson = "{\"name\": \"John\",}"  -- 尾随逗号
  case parseJSONWithError invalidJson of
    Left err -> putStrLn $ "Error: " ++ err
    Right val -> putStrLn $ "Success: " ++ show val