IndexJSON.hs

#!/usr/bin/env stack
-- stack --resolver lts-3.13 --install-ghc runghc --package base --package attoparsec --package text

{-# LANGUAGE OverloadedStrings #-}

import Control.Applicative ((<|>), many)
import Data.Attoparsec.Text (Parser)
import Data.Attoparsec.Combinator (lookAhead)
import qualified Data.Attoparsec.Text as P -- (*)
import Data.Char (chr)
import Data.Functor (($>))
import Data.Function ((&))
import Data.Text (Text)
import qualified Data.Text as T (length)
import qualified Data.Text.IO as T (readFile)
import System.Environment (getArgs)

parseValue :: Parser Int
parseValue = parseNull
         <|> parseBool
         <|> parseObject
         <|> parseArray
         <|> parseNumber
         <|> parseString

string :: Text -> Parser Int
string x = P.string x $> T.length x

parseNull = string "null"

parseBool = string "true" <|> string "false"

char :: Char -> Parser Int
char x = P.char x $> 1

parseWhitespace :: Parser Int
parseWhitespace = fmap sum . many . P.choice $ char <$> " \t\n\r"

parseDigit19 = P.choice $ char <$> "123456789"
parseDigit = char '0' <|> parseDigit19

many' :: Parser Int -> Parser Int
many' x = sum <$> P.many' x

many1 :: Parser Int -> Parser Int
many1 x = sum <$> P.many1 x

optional :: Parser Int -> Parser Int
optional x = P.choice [x, pure 0]

(<+>) :: Parser Int -> Parser Int -> Parser Int
(<+>) p q = (+) <$> p <*> q; infixl 2 <+>

parseInt = (char '0' $> 0) <|> (parseDigit19 <+> many' parseDigit)
parseFractional = char '.' <+> many1 parseDigit

parseExponent = char 'e' <|> char 'E'
            <+> optional (char '+' <|> char '-') 
            <+> many1 parseDigit

parseNumber = optional (char '-')
          <+> parseInt
          <+> optional parseFractional
          <+> optional parseExponent

parseUnescaped' = [0x20..0x21]
               ++ [0x23..0x5B]
               ++ [0x5D..0x10FFFF]
                & P.choice . fmap (P.char . chr)

isHexDigit :: Char -> Bool
isHexDigit c = or
  [ c >= '0' && c <= '9'
  , c >= 'a' && c <= 'f'
  , c >= 'A' && c <= 'F'
  ]

parseEscaped' = (:) <$> P.char '\\' <*> P.choice
  [ pure <$> P.choice (map P.char "\"\\/bfnrt")
  , (:) <$> P.char 'u' <*> P.count 4 (P.satisfy isHexDigit)
  ]

parseChar' = parseEscaped' <|> fmap pure parseUnescaped'

parseString' = P.char '"' *> (concat <$> P.many' parseChar') <* P.char '"'

parseChar = length <$> parseChar'

parseString = char '"' <+> many' parseChar <+> char '"'

withInsignificantWhitespace :: Parser Int -> Parser Int
withInsignificantWhitespace parse = 
  parseWhitespace <+> parse <+> parseWhitespace

parseBeginArray = withInsignificantWhitespace $ char '['
parseEndArray = withInsignificantWhitespace $ char ']'
parseValueSeparator = withInsignificantWhitespace $ char ','

sepBy1 :: Parser Int -> Parser Int -> Parser Int
sepBy1 p s = scan where scan = p <+> ((s <+> scan) <|> pure 0)

sepBy :: Parser Int -> Parser Int -> Parser Int
sepBy p s = (p <+> ((s <+> sepBy1 p s) <|> pure 0)) <|> pure 0

parseArray = parseBeginArray
         <+> parseValue `sepBy` parseValueSeparator
         <+> parseEndArray

parseBeginObject = withInsignificantWhitespace $ char '{'
parseEndObject = withInsignificantWhitespace $ char '}'
parseNameSeparator = withInsignificantWhitespace $ char ':'

parseMember = parseString <+> (parseNameSeparator <+> parseValue)

parseObject = parseBeginObject
          <+> parseMember `sepBy` parseValueSeparator
          <+> parseEndObject

-- Presentation hacks:

manyIter :: (a -> Parser a) -> a -> Parser [a]
manyIter f a = f a >>= \b -> (b:) <$> (manyIter f b <|> pure [])

parseMember' p = do
  (k, n) <- (,) <$> lookAhead parseString' <*> parseString
  conte <- (+ n) <$> parseNameSeparator <+> parseValue
  trail <- parseValueSeparator <|> pure 0
  return $ (,) k (succ p, p + conte, p + conte + trail)

_3 (_, _, v) = v

parseObject' = do
  p <- parseBeginObject
  res <- manyIter (parseMember' . _3 . snd) ("", (0, p, p)) 
  parseEndObject $> res

main = do
  result <- head <$> getArgs >>= fmap (P.parseOnly parseObject') . T.readFile
  case result of { Left err -> error err; Right idx -> mapM print idx; }