module Son.Parser where

import Control.Monad.Fail (fail)
import Data.Aeson
import Data.Attoparsec.Text
import Data.Char (isDigit)
import Data.HashMap.Strict (HashMap)
import Data.Scientific (Scientific)
import Data.String (unlines)
import Data.Vector (Vector)
import Protolude hiding (option, take)

import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T
import qualified Data.Vector as V

sonValue :: Parser Value
sonValue = fmap Object       sonObject
       <|> fmap Array        sonArray
       <|> fmap String       sonString
       <|> fmap Number       sonNumber
       <|> fmap Bool         sonBoolean
       <|> fmap (const Null) sonNull

sonObject :: Parser (HashMap Text Value)
sonObject = do
  void (char '{')
  es <- element `sepBy` char ','
  void (char '}')
  checkOrder es
  pure (HM.fromList es)
  where
    element :: Parser (Text, Value)
    element = do
      t <- sonString
      void (char ':')
      x <- sonValue
      pure (t,x)

    checkOrder :: [(Text, Value)] -> Parser ()
    checkOrder = void . foldM f Nothing
      where
        f :: Maybe Text -> (Text, a) -> Parser (Maybe Text)
        f Nothing    (k,_) = pure (Just k)
        f (Just acc) (k,_)
          | k > acc   = pure (Just k)
          | otherwise = fail ("Key out of order: " <> T.unpack k)

sonArray :: Parser (Vector Value)
sonArray = do
  void (char '[')
  xs <- V.fromList <$> sonValue `sepBy` char ','
  void (char ']')
  pure xs

sonString :: Parser Text
sonString = do
  void (char '"')
  ts <- mempty <$ char '"'
    <|> body <* char '"'
  pure (T.concat ts)
    where
      body :: Parser [Text]
      body = many (takeWhile1 (\c -> c /= '"' && c /= '\\') <|> unescape)

      unescape :: Parser Text
      unescape = do
        void (char '\\')
        T.singleton <$> (shortcutEscape <|> unescapeCodePoint)

      shortcutEscape :: Parser Char
      shortcutEscape =
            char '"'
        <|> char '\\'
        -- NOTE: solidus (U+002F) isn't listed here, because even though
        -- JSON allows it to be escaped with @\/@ it doesn't have to be.
        <|> (char 'b' *> pure '\x08') -- backspace
        <|> (char 't' *> pure '\x09') -- tab
        <|> (char 'n' *> pure '\x0a') -- line feed
        <|> (char 'f' *> pure '\x0c') -- form feed
        <|> (char 'r' *> pure '\x0d') -- carriage return

      unescapeCodePoint :: Parser Char
      unescapeCodePoint = do
        void (char 'u')
        void (char '0')
        void (char '0')
        n <- take 2
        case n of
          "00" -> pure '\x00'
          "01" -> pure '\x01'
          "02" -> pure '\x02'
          "03" -> pure '\x03'
          "04" -> pure '\x04'
          "05" -> pure '\x05'
          "06" -> pure '\x06'
          "07" -> pure '\x07'
  < first set of shortcut escapes >
          "0b" -> pure '\x0b'
  < second set of shortcut escapes >
          "0e" -> pure '\x0e'
          "0f" -> pure '\x0f'
          "10" -> pure '\x10'
          "11" -> pure '\x11'
          "12" -> pure '\x12'
          "13" -> pure '\x13'
          "14" -> pure '\x14'
          "15" -> pure '\x15'
          "16" -> pure '\x16'
          "17" -> pure '\x17'
          "18" -> pure '\x18'
          "19" -> pure '\x19'
          "1a" -> pure '\x1a'
          "1b" -> pure '\x1b'
          "1c" -> pure '\x1c'
          "1d" -> pure '\x1d'
          "1e" -> pure '\x1e'
          "1f" -> pure '\x1f'
          _ -> fail ("\\u escape followed by invalid sequence: " <> T.unpack n)

sonNumber :: Parser Scientific
sonNumber = makeScientific -- TODO: note that Order matters here.
        <|> 0 <$ char '0'
  where
  Use @nonZero@ to make sure the number 's a valid Son number ,
  then use @readMaybe@ to turn it into a 
    --
  This would be more efficient if @nonZero@ could create the
    -- @Scientific@ itself. To do so we'll need a function going from
  @Bool - > [     [     Scientific@ , where the @Bool@ is
    -- the sign of the number and the @Char@s are digits.
    makeScientific :: Parser Scientific
    makeScientific = do
      (t, ()) <- match nonZero
      case readMaybe (T.unpack t) of
        Nothing -> fail (unlines [ "readMaybe failed (this should"
                                 , " never happen) on input: "
                                 , show t
                                 ])
        Just s  -> pure s

nonZero :: Parser ()
nonZero = do
  option () (void (char '-'))
  startsWithNonZero <|> char '0' *> void sonFraction
  where
    startsWithNonZero :: Parser ()
    startsWithNonZero = do
      void sonPositiveInteger
      option () (void sonFraction)

sonPositiveInteger :: Parser Text
sonPositiveInteger = do
  n <- takeTill (not . isDigit)
  when (T.null n) (fail "integer part is empty")
  when (T.head n == '0') (fail ("integer part stars with zero: " <> show n))
  pure n

sonFraction :: Parser Text
sonFraction = do
  void (char '.')
  n <- takeTill (not . isDigit)
  when (T.null n) (fail "no digits after decimal point")
  when (T.last n == '0') (fail (show ("fractional part ends in zero: " <> n)))
  pure n

sonBoolean :: Parser Bool
sonBoolean = True <$ string "true"
         <|> False <$ string "false"

sonNull :: Parser ()
sonNull = () <$ string "null"

 NOTE: solidus (U+002F) isn't listed here, because even though
 JSON allows it to be escaped with @\/@ it doesn't have to be.
 backspace
 tab
 line feed
 form feed
 carriage return
 TODO: note that Order matters here.

 @Scientific@ itself. To do so we'll need a function going from
 the sign of the number and the @Char@s are digits.
module Son.Parser where

import Control.Monad.Fail (fail)
import Data.Aeson
import Data.Attoparsec.Text
import Data.Char (isDigit)
import Data.HashMap.Strict (HashMap)
import Data.Scientific (Scientific)
import Data.String (unlines)
import Data.Vector (Vector)
import Protolude hiding (option, take)

import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T
import qualified Data.Vector as V

sonValue :: Parser Value
sonValue = fmap Object       sonObject
       <|> fmap Array        sonArray
       <|> fmap String       sonString
       <|> fmap Number       sonNumber
       <|> fmap Bool         sonBoolean
       <|> fmap (const Null) sonNull

sonObject :: Parser (HashMap Text Value)
sonObject = do
  void (char '{')
  es <- element `sepBy` char ','
  void (char '}')
  checkOrder es
  pure (HM.fromList es)
  where
    element :: Parser (Text, Value)
    element = do
      t <- sonString
      void (char ':')
      x <- sonValue
      pure (t,x)

    checkOrder :: [(Text, Value)] -> Parser ()
    checkOrder = void . foldM f Nothing
      where
        f :: Maybe Text -> (Text, a) -> Parser (Maybe Text)
        f Nothing    (k,_) = pure (Just k)
        f (Just acc) (k,_)
          | k > acc   = pure (Just k)
          | otherwise = fail ("Key out of order: " <> T.unpack k)

sonArray :: Parser (Vector Value)
sonArray = do
  void (char '[')
  xs <- V.fromList <$> sonValue `sepBy` char ','
  void (char ']')
  pure xs

sonString :: Parser Text
sonString = do
  void (char '"')
  ts <- mempty <$ char '"'
    <|> body <* char '"'
  pure (T.concat ts)
    where
      body :: Parser [Text]
      body = many (takeWhile1 (\c -> c /= '"' && c /= '\\') <|> unescape)

      unescape :: Parser Text
      unescape = do
        void (char '\\')
        T.singleton <$> (shortcutEscape <|> unescapeCodePoint)

      shortcutEscape :: Parser Char
      shortcutEscape =
            char '"'
        <|> char '\\'

      unescapeCodePoint :: Parser Char
      unescapeCodePoint = do
        void (char 'u')
        void (char '0')
        void (char '0')
        n <- take 2
        case n of
          "00" -> pure '\x00'
          "01" -> pure '\x01'
          "02" -> pure '\x02'
          "03" -> pure '\x03'
          "04" -> pure '\x04'
          "05" -> pure '\x05'
          "06" -> pure '\x06'
          "07" -> pure '\x07'
  < first set of shortcut escapes >
          "0b" -> pure '\x0b'
  < second set of shortcut escapes >
          "0e" -> pure '\x0e'
          "0f" -> pure '\x0f'
          "10" -> pure '\x10'
          "11" -> pure '\x11'
          "12" -> pure '\x12'
          "13" -> pure '\x13'
          "14" -> pure '\x14'
          "15" -> pure '\x15'
          "16" -> pure '\x16'
          "17" -> pure '\x17'
          "18" -> pure '\x18'
          "19" -> pure '\x19'
          "1a" -> pure '\x1a'
          "1b" -> pure '\x1b'
          "1c" -> pure '\x1c'
          "1d" -> pure '\x1d'
          "1e" -> pure '\x1e'
          "1f" -> pure '\x1f'
          _ -> fail ("\\u escape followed by invalid sequence: " <> T.unpack n)

sonNumber :: Parser Scientific
        <|> 0 <$ char '0'
  where
  Use @nonZero@ to make sure the number 's a valid Son number ,
  then use @readMaybe@ to turn it into a 
  This would be more efficient if @nonZero@ could create the
  @Bool - > [     [     Scientific@ , where the @Bool@ is
    makeScientific :: Parser Scientific
    makeScientific = do
      (t, ()) <- match nonZero
      case readMaybe (T.unpack t) of
        Nothing -> fail (unlines [ "readMaybe failed (this should"
                                 , " never happen) on input: "
                                 , show t
                                 ])
        Just s  -> pure s

nonZero :: Parser ()
nonZero = do
  option () (void (char '-'))
  startsWithNonZero <|> char '0' *> void sonFraction
  where
    startsWithNonZero :: Parser ()
    startsWithNonZero = do
      void sonPositiveInteger
      option () (void sonFraction)

sonPositiveInteger :: Parser Text
sonPositiveInteger = do
  n <- takeTill (not . isDigit)
  when (T.null n) (fail "integer part is empty")
  when (T.head n == '0') (fail ("integer part stars with zero: " <> show n))
  pure n

sonFraction :: Parser Text
sonFraction = do
  void (char '.')
  n <- takeTill (not . isDigit)
  when (T.null n) (fail "no digits after decimal point")
  when (T.last n == '0') (fail (show ("fractional part ends in zero: " <> n)))
  pure n

sonBoolean :: Parser Bool
sonBoolean = True <$ string "true"
         <|> False <$ string "false"

sonNull :: Parser ()
sonNull = () <$ string "null"
