jsonをパースするhaskellのコード

Parser.hs

module Json.Parser(
  jsonValue
) where

import Text.Parsec         hiding ((<|>), many)
import Text.Parsec.String  (Parser)

import Control.Applicative
import Control.Monad
import Data.Monoid
import Data.Maybe          (fromJust)

-- --------
-- Builder型 - json numberをパースするためのサポート型
-- --------

data Builder = Builder {
    integral  :: Parser (Maybe String),
    float :: Parser (Maybe String)
}

-- --------
-- 'Which'型 - 'joinM'をサポートする型
-- --------

data Which
    = Both
    | LeftOnly
    | RightOnly
    | Neither

-- | 'joinM' takes 'Maybe a' and 'Maybe a' and joins it
-- and returns 'Maybe a' with Constraint 'Monoid a'
joinM :: (Monoid a) => Maybe a -> Maybe a -> (Which, Maybe a)
joinM Nothing Nothing   = (Neither, Nothing)
joinM x Nothing         = (LeftOnly, x)
joinM Nothing x         = (RightOnly, x)
joinM (Just x) (Just y) = (Both, Just (x <> y))

-- | 'joinL' takes 'Maybe a' and '[a]' and returns 'Maybe [a]'
joinL :: Maybe a -> [a] -> Maybe [a]
joinL Nothing xs  = Just xs
joinL (Just x) xs = Just (x:xs)

-- --------
-- jsonデータ型
-- --------

-- |'JsonValue' A data type representing json
data JsonValue
    = JsonBool Bool
    | JsonString String
    | JsonInt Integer
    | JsonFloat Double
    | JsonArray [JsonValue]
    | JsonObject [(String, JsonValue)]
    deriving (Show, Eq)

-- --------
-- ホワイトスペースを検出
-- --------

-- | 'ws' matchs white spaces
ws :: Parser String
ws = many $ oneOf " \t\n"

-- --------
-- json booleanに対応するマッチャー
-- --------

-- jsonのtrueを検出
-- | 'matchTrue' matchs json boolean value 'true'.
matchTrue :: Parser String
matchTrue = string "true"

-- jsonのfalseを検出
-- | 'matchFalse' matchs json boolean value 'false'.
matchFalse :: Parser String
matchFalse = string "false"

-- 常時Trueを返す
-- | 'alwaysTrue' returns always 'True'
alwaysTrue :: Parser Bool
alwaysTrue = pure True

-- 常時Falseを返す
-- | 'alwaysFalse' returns always 'False'
alwaysFalse :: Parser Bool
alwaysFalse = pure False

-- booleanからBoolに変換
-- | 'boolTrue' takes json boolean 'true' and returns 'True'
boolTrue :: Parser Bool
boolTrue = matchTrue *> alwaysTrue

-- | 'boolFalse' takes json boolean 'false' and returns 'False'
boolFalse :: Parser Bool
boolFalse = matchFalse *> alwaysFalse

-- | 'bool' takes json boolean and return 'Bool'
bool :: Parser Bool
bool = boolTrue <|> boolFalse

-- jsonのbooleanをJsonBoolに変換
-- | 'jsonBool' takes json boolean and return 'JsonBool'
jsonBool :: Parser JsonValue
jsonBool = JsonBool <$> bool

-- ---------
-- json stringのマッチャー
-- ---------

-- jsonのstringを検出
-- | 'stringLiteral' takes string and returns String
stringLiteral :: Parser String
stringLiteral = char '"' *> many (noneOf ['"']) <* char '"'

-- jsonのstringをJsonValueに変換
-- | 'jsonString' takes json string and returns 'JsonString'
jsonString :: Parser JsonValue
jsonString = JsonString <$> stringLiteral

-- --------
-- json numberのパーサー
-- --------

-- | 'intLiteral' matchs integer starting 1 to 9
intLiteral :: Parser String
intLiteral = (:) <$> oneToNine <*> many digit

-- | 'oneToNine' returns matcher for 1 to 9
oneToNine :: Parser Char
oneToNine = oneOf (concatMap show [1..9])

-- | 'intPart' matchs integer with sign
intPart :: Parser (Maybe String)
intPart = (joinL) <$> optionMaybe (char '-') <*> intLiteral

-- | 'floatPart' matchs floating part of number
floatPart :: Parser (Maybe String)
floatPart = optionMaybe $ flp
    where
        flp = (:) <$> char '.' <*> many1 digit

-- | 'builder' takes json number and returns 'Builder'
builder :: Builder
builder = Builder intPart floatPart

-- | 'jsonNumber' takes json number and returns 'JsonValue'
jsonNumber :: Parser JsonValue
jsonNumber = maybeNumber builder

-- | 'maybeNumber' takes 'Builder' and returns 'Maybe String'
maybeNumber :: Builder -> Parser JsonValue
maybeNumber (Builder x y) = do
    num <- joinM <$> x <*> y
    case num of
        (Neither, Nothing)  -> JsonInt <$> pure 0
        (LeftOnly, Just i)  -> JsonInt <$> toInt i
        (RightOnly, Just f) -> JsonFloat <$> toFloat ('0':f)
        (Both, Just f)      -> JsonFloat <$> toFloat f

toInt :: String -> Parser Integer
toInt i = pure $ read i

toFloat :: String -> Parser Double
toFloat f = pure $ read f

-- --------
-- jsonオブジェクト全体のパーサー
-- --------

-- | 'jsonValue' takes json literal and returns 'JsonValue'
jsonValue :: Parser JsonValue
jsonValue
    = jsonBool
    <|> jsonString
    <|> jsonNumber
    <|> jsonArray
    <|> jsonObject

-- --------
-- json arrayのパーサー
-- --------

-- | 'arrayLiteral' takes json array literal and returns '[JsonValue]'
arrayLiteral :: Parser [JsonValue]
arrayLiteral
    = (ws *> char '[' <* ws)
    *> (jsonValue `sepBy` (ws *> char ',' <* ws))
    <* (ws *> char ']' <* ws)

-- | 'jsonArray' takes json array and returns 'JsonValue'
jsonArray :: Parser JsonValue
jsonArray = JsonArray <$> arrayLiteral

-- -------
-- json objectのパーサー
-- -------

-- | 'objectEntry' takes json object literal and returns '(String, JsonValue)'
objectEntry :: Parser (String, JsonValue)
objectEntry = do
    key <- stringLiteral
    ws *> char ':' <* ws
    value <- jsonValue
    return (key, value)

-- | 'jsonObject' takes json literal and returns 'JsonObject'
jsonObject :: Parser JsonValue
jsonObject = JsonObject
    <$> ((ws *> char '{' <* ws)
    *> (objectEntry `sepBy` (ws *> char ',' <* ws))
    <* (ws *> char '}' <* ws))