----------------------------------------------------------------------------
{-# LANGUAGE CPP               #-}
{-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso.JSON.Lexer
-- Copyright   :  (C) 2016-2026 David M. Johnson
-- License     :  BSD3-style (see the file LICENSE)
-- Maintainer  :  David M. Johnson <code@dmj.io>
-- Stability   :  experimental
-- Portability :  non-portable
--
-- = Overview
--
-- "Miso.JSON.Lexer" is the first stage of miso's pure Haskell JSON pipeline,
-- which is used for server-side rendering (SSR). It tokenises a
-- 'Miso.String.MisoString' into a stream of 'Token' values consumed by
-- "Miso.JSON.Parser".
--
-- This module is __internal__. Application code should use "Miso.JSON" or
-- "Miso.JSON.Parser" ('Miso.JSON.Parser.decodePure') instead.
--
-- This module was ported from <https://github.com/dmjio/json-test> by
-- <https://github.com/ners @ners>.
--
-- = Token types
--
-- @
-- data 'Token'
--   = 'TokenPunctuator' Char    -- one of @[ ] { } , :@
--   | 'TokenNumber'     Double  -- JSON number (integer or floating-point)
--   | 'TokenBool'       Bool    -- @true@ or @false@
--   | 'TokenString'     'Miso.String.MisoString' -- quoted string with escape sequences
--   | 'TokenNull'               -- @null@
-- @
--
-- String tokens handle all
-- <https://www.rfc-editor.org/rfc/rfc8259#section-7 RFC 8259 escape sequences>
-- including @\\uXXXX@ and UTF-16 surrogate pairs (@\\uD800\\uDC00@).
--
-- = See also
--
-- * "Miso.JSON.Parser" — consumes 'Token' streams produced here
-- * "Miso.JSON.Types" — 'Miso.JSON.Types.Value' produced by the parser
-- * "Miso.Util.Lexer" — the underlying 'Miso.Util.Lexer.Lexer' combinator library
----------------------------------------------------------------------------
module Miso.JSON.Lexer (Token (..), tokens) where
----------------------------------------------------------------------------
import           Control.Applicative (Alternative (some, many), optional)
import           Control.Monad (replicateM)
import           Data.Char (isHexDigit, chr, isSpace)
import           Data.Foldable (Foldable (fold))
import           Data.Functor (void)
import           Data.Ix (Ix (inRange))
import           Data.Maybe (catMaybes)
import           Numeric (readHex)
import           Prelude hiding (null)
----------------------------------------------------------------------------
import           Miso.String (fromMisoString, ToMisoString (toMisoString), MisoString)
import           Miso.Util (oneOf)
import           Miso.Util.Lexer hiding (string', token)
----------------------------------------------------------------------------
#if __GLASGOW_HASKELL__ <= 881
import Control.Applicative (liftA2)
#endif
----------------------------------------------------------------------------
-- | A single lexical token of JSON text, produced by 'tokens'.
--
-- Punctuators are the structural characters @{}[],:@; the remaining
-- constructors carry already-decoded literals.
data Token
  = TokenPunctuator Char
  | TokenNumber Double
  | TokenBool Bool
  | TokenString MisoString
  | TokenNull
  deriving (Token -> Token -> Bool
(Token -> Token -> Bool) -> (Token -> Token -> Bool) -> Eq Token
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Token -> Token -> Bool
== :: Token -> Token -> Bool
$c/= :: Token -> Token -> Bool
/= :: Token -> Token -> Bool
Eq, Int -> Token -> ShowS
[Token] -> ShowS
Token -> [Char]
(Int -> Token -> ShowS)
-> (Token -> [Char]) -> ([Token] -> ShowS) -> Show Token
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Token -> ShowS
showsPrec :: Int -> Token -> ShowS
$cshow :: Token -> [Char]
show :: Token -> [Char]
$cshowList :: [Token] -> ShowS
showList :: [Token] -> ShowS
Show)
----------------------------------------------------------------------------
number :: Lexer Double
number :: Lexer Double
number = Text -> Double
forall a. FromMisoString a => Text -> a
fromMisoString (Text -> Double)
-> ([Maybe Text] -> Text) -> [Maybe Text] -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([Text] -> Text)
-> ([Maybe Text] -> [Text]) -> [Maybe Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe Text] -> [Text]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Text] -> Double) -> Lexer [Maybe Text] -> Lexer Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Lexer (Maybe Text)] -> Lexer [Maybe Text]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
  [ Lexer Text -> Lexer (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Lexer Text -> Lexer (Maybe Text))
-> Lexer Text -> Lexer (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Lexer Text
string Text
"-"
  , Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Lexer Text -> Lexer (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lexer Text
int
  , Lexer Text -> Lexer (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Lexer Text -> Lexer (Maybe Text))
-> Lexer Text -> Lexer (Maybe Text)
forall a b. (a -> b) -> a -> b
$ (Text -> Text -> Text) -> Lexer Text -> Lexer Text -> Lexer Text
forall a b c. (a -> b -> c) -> Lexer a -> Lexer b -> Lexer c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
(<>) (Text -> Lexer Text
string Text
".") Lexer Text
int
  , Lexer Text -> Lexer (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Lexer Text -> Lexer (Maybe Text))
-> Lexer Text -> Lexer (Maybe Text)
forall a b. (a -> b) -> a -> b
$ (Text -> Text -> Text) -> Lexer Text -> Lexer Text -> Lexer Text
forall a b c. (a -> b -> c) -> Lexer a -> Lexer b -> Lexer c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
(<>) ([Lexer Text] -> Lexer Text
forall (f :: * -> *) a. Alternative f => [f a] -> f a
oneOf ([Lexer Text] -> Lexer Text) -> [Lexer Text] -> Lexer Text
forall a b. (a -> b) -> a -> b
$ Text -> Lexer Text
string (Text -> Lexer Text) -> [Text] -> [Lexer Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text
"e", Text
"e+", Text
"e-", Text
"E", Text
"E+", Text
"E-"]) Lexer Text
int
  ] where
      digit :: Lexer Char
digit = (Char -> Bool) -> Lexer Char
satisfy ((Char -> Bool) -> Lexer Char) -> (Char -> Bool) -> Lexer Char
forall a b. (a -> b) -> a -> b
$ (Char, Char) -> Char -> Bool
forall a. Ix a => (a, a) -> a -> Bool
inRange (Char
'0', Char
'9')
      int :: Lexer Text
int = [Char] -> Text
forall str. ToMisoString str => str -> Text
toMisoString ([Char] -> Text) -> Lexer [Char] -> Lexer Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lexer Char -> Lexer [Char]
forall a. Lexer a -> Lexer [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some Lexer Char
digit
----------------------------------------------------------------------------
bool :: Lexer Bool
bool :: Lexer Bool
bool = [Lexer Bool] -> Lexer Bool
forall (f :: * -> *) a. Alternative f => [f a] -> f a
oneOf
  [ Bool
False Bool -> Lexer Text -> Lexer Bool
forall a b. a -> Lexer b -> Lexer a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Lexer Text
string Text
"false"
  , Bool
True Bool -> Lexer Text -> Lexer Bool
forall a b. a -> Lexer b -> Lexer a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Lexer Text
string Text
"true"
  ]
----------------------------------------------------------------------------
string' :: Lexer MisoString
string' :: Lexer Text
string' = Char -> Lexer Char
char Char
'"' Lexer Char -> Lexer Text -> Lexer Text
forall a b. Lexer a -> Lexer b -> Lexer b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ([Char] -> Text
forall str. ToMisoString str => str -> Text
toMisoString ([Char] -> Text) -> Lexer [Char] -> Lexer Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lexer Char -> Lexer [Char]
forall a. Lexer a -> Lexer [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Lexer Char
character) Lexer Text -> Lexer Char -> Lexer Text
forall a b. Lexer a -> Lexer b -> Lexer a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Lexer Char
char Char
'"'
  where
    character :: Lexer Char
character = [Lexer Char] -> Lexer Char
forall (f :: * -> *) a. Alternative f => [f a] -> f a
oneOf
      [ (Char -> Bool) -> Lexer Char
satisfy ((Char -> Bool) -> Lexer Char) -> (Char -> Bool) -> Lexer Char
forall a b. (a -> b) -> a -> b
$ \Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'"' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\\'
      , Lexer Char
escapedCharacter
      ]
    hexDigit :: Lexer Char
hexDigit = (Char -> Bool) -> Lexer Char
satisfy Char -> Bool
isHexDigit
    escaped :: Lexer b -> Lexer b
escaped = (Char -> Lexer Char
char Char
'\\' Lexer Char -> Lexer b -> Lexer b
forall a b. Lexer a -> Lexer b -> Lexer b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>)
    escapedCharacter :: Lexer Char
escapedCharacter = Lexer Char -> Lexer Char
forall {b}. Lexer b -> Lexer b
escaped (Lexer Char -> Lexer Char) -> Lexer Char -> Lexer Char
forall a b. (a -> b) -> a -> b
$ [Lexer Char] -> Lexer Char
forall (f :: * -> *) a. Alternative f => [f a] -> f a
oneOf
      [ Char -> Lexer Char
char Char
'"'
      , Char -> Lexer Char
char Char
'\\'
      , Char -> Lexer Char
char Char
'/'
      , Char
'\b' Char -> Lexer Char -> Lexer Char
forall a b. a -> Lexer b -> Lexer a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Lexer Char
char Char
'b'
      , Char
'\f' Char -> Lexer Char -> Lexer Char
forall a b. a -> Lexer b -> Lexer a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Lexer Char
char Char
'f'
      , Char
'\n' Char -> Lexer Char -> Lexer Char
forall a b. a -> Lexer b -> Lexer a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Lexer Char
char Char
'n'
      , Char
'\r' Char -> Lexer Char -> Lexer Char
forall a b. a -> Lexer b -> Lexer a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Lexer Char
char Char
'r'
      , Char
'\t' Char -> Lexer Char -> Lexer Char
forall a b. a -> Lexer b -> Lexer a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Lexer Char
char Char
't'
      , Lexer Int
unicodeHexQuad Lexer Int -> (Int -> Lexer Char) -> Lexer Char
forall a b. Lexer a -> (a -> Lexer b) -> Lexer b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int
high -> do
          if (Int, Int) -> Int -> Bool
forall a. Ix a => (a, a) -> a -> Bool
inRange (Int, Int)
highSurrogateRange Int
high
            then do
              low <- Lexer Int -> Lexer Int
forall {b}. Lexer b -> Lexer b
escaped Lexer Int
unicodeHexQuad
              if inRange lowSurrogateRange low
                then
                  pure . chr . sum $
                    [ (high - fst highSurrogateRange) * 0x400
                    , low - fst lowSurrogateRange
                    , 0x10000
                    ]
                else oops
            else
              Char -> Lexer Char
forall a. a -> Lexer a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char -> Lexer Char) -> Char -> Lexer Char
forall a b. (a -> b) -> a -> b
$ Int -> Char
chr Int
high
      ]
    highSurrogateRange :: (Int, Int)
highSurrogateRange = (Int
0xD800, Int
0xDBFF)
    lowSurrogateRange :: (Int, Int)
lowSurrogateRange = (Int
0xDC00, Int
0xDFFF)
    unicodeHexQuad :: Lexer Int
unicodeHexQuad = Char -> Lexer Char
char Char
'u' Lexer Char -> Lexer Int -> Lexer Int
forall a b. Lexer a -> Lexer b -> Lexer b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> do
        [(num, "")] <- ReadS Int
forall a. (Eq a, Num a) => ReadS a
readHex ReadS Int -> Lexer [Char] -> Lexer [(Int, [Char])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Lexer Char -> Lexer [Char]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
4 Lexer Char
hexDigit
        pure num
----------------------------------------------------------------------------
null :: Lexer ()
null :: Lexer ()
null = Lexer Text -> Lexer ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Text -> Lexer Text
string Text
"null")
----------------------------------------------------------------------------
punctuator :: Lexer Char
punctuator :: Lexer Char
punctuator = [Lexer Char] -> Lexer Char
forall (f :: * -> *) a. Alternative f => [f a] -> f a
oneOf (Char -> Lexer Char
char (Char -> Lexer Char) -> [Char] -> [Lexer Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char]
"[]{},:")
----------------------------------------------------------------------------
whitespace :: Lexer ()
whitespace :: Lexer ()
whitespace = Lexer Char -> Lexer ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ((Char -> Bool) -> Lexer Char
satisfy Char -> Bool
isSpace)
----------------------------------------------------------------------------
token :: Lexer Token
token :: Lexer Token
token = [Lexer Token] -> Lexer Token
forall (f :: * -> *) a. Alternative f => [f a] -> f a
oneOf
  [ Char -> Token
TokenPunctuator (Char -> Token) -> Lexer Char -> Lexer Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lexer Char
punctuator
  , Double -> Token
TokenNumber (Double -> Token) -> Lexer Double -> Lexer Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lexer Double
number
  , Bool -> Token
TokenBool (Bool -> Token) -> Lexer Bool -> Lexer Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lexer Bool
bool
  , Text -> Token
TokenString (Text -> Token) -> Lexer Text -> Lexer Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lexer Text
string'
  , Token
TokenNull Token -> Lexer () -> Lexer Token
forall a b. a -> Lexer b -> Lexer a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Lexer ()
null
  ]
----------------------------------------------------------------------------
-- | Lexes JSON source into a list of t'Token', skipping whitespace.
--
-- The first half of 'Miso.JSON.decode'; feed the result to
-- "Miso.JSON.Parser".
tokens :: Lexer [Token]
tokens :: Lexer [Token]
tokens = Lexer Token -> Lexer [Token]
forall a. Lexer a -> Lexer [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (Lexer () -> Lexer [()]
forall a. Lexer a -> Lexer [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Lexer ()
whitespace Lexer [()] -> Lexer Token -> Lexer Token
forall a b. Lexer a -> Lexer b -> Lexer b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Lexer Token
token)
----------------------------------------------------------------------------