----------------------------------------------------------------------------
{-# LANGUAGE CPP               #-}
{-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso.JSON.Lexer
-- Copyright   :  (C) 2016-2025 David M. Johnson
-- License     :  BSD3-style (see the file LICENSE)
-- Maintainer  :  David M. Johnson <code@dmj.io>
-- Stability   :  experimental
-- Portability :  non-portable
--
-- A Lexer for the JSON specification. Meant to be used on the server w/ SSR.
--
-- This was ported from <https://github.com/dmjio/json-test> by [@ners](https://github.com/ners)
-- 
----------------------------------------------------------------------------
module Miso.JSON.Lexer (Token (..), tokens) where
----------------------------------------------------------------------------
import           Control.Applicative (optional, Alternative (some, many))
import           Data.Char (isHexDigit, chr, isSpace)
import           Data.Foldable (Foldable (fold))
import           Data.Functor (void)
import           Data.Ix (Ix (inRange))
import           Data.Maybe (catMaybes, listToMaybe)
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
----------------------------------------------------------------------------
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 = MisoString -> Double
forall a. FromMisoString a => MisoString -> a
fromMisoString (MisoString -> Double)
-> ([Maybe MisoString] -> MisoString)
-> [Maybe MisoString]
-> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [MisoString] -> MisoString
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([MisoString] -> MisoString)
-> ([Maybe MisoString] -> [MisoString])
-> [Maybe MisoString]
-> MisoString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe MisoString] -> [MisoString]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe MisoString] -> Double)
-> Lexer [Maybe MisoString] -> Lexer Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Lexer (Maybe MisoString)] -> Lexer [Maybe MisoString]
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 MisoString -> Lexer (Maybe MisoString)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Lexer MisoString -> Lexer (Maybe MisoString))
-> Lexer MisoString -> Lexer (Maybe MisoString)
forall a b. (a -> b) -> a -> b
$ MisoString -> Lexer MisoString
string MisoString
"-"
  , MisoString -> Maybe MisoString
forall a. a -> Maybe a
Just (MisoString -> Maybe MisoString)
-> Lexer MisoString -> Lexer (Maybe MisoString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lexer MisoString
int
  , Lexer MisoString -> Lexer (Maybe MisoString)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Lexer MisoString -> Lexer (Maybe MisoString))
-> Lexer MisoString -> Lexer (Maybe MisoString)
forall a b. (a -> b) -> a -> b
$ (MisoString -> MisoString -> MisoString)
-> Lexer MisoString -> Lexer MisoString -> Lexer MisoString
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 MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
(<>) (MisoString -> Lexer MisoString
string MisoString
".") Lexer MisoString
int
  , Lexer MisoString -> Lexer (Maybe MisoString)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Lexer MisoString -> Lexer (Maybe MisoString))
-> Lexer MisoString -> Lexer (Maybe MisoString)
forall a b. (a -> b) -> a -> b
$ (MisoString -> MisoString -> MisoString)
-> Lexer MisoString -> Lexer MisoString -> Lexer MisoString
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 MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
(<>) ([Lexer MisoString] -> Lexer MisoString
forall (f :: * -> *) a. Alternative f => [f a] -> f a
oneOf ([Lexer MisoString] -> Lexer MisoString)
-> [Lexer MisoString] -> Lexer MisoString
forall a b. (a -> b) -> a -> b
$ MisoString -> Lexer MisoString
string (MisoString -> Lexer MisoString)
-> [MisoString] -> [Lexer MisoString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MisoString
"e", MisoString
"e+", MisoString
"e-", MisoString
"E", MisoString
"E+", MisoString
"E-"]) Lexer MisoString
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 MisoString
int = [Char] -> MisoString
forall str. ToMisoString str => str -> MisoString
toMisoString ([Char] -> MisoString) -> Lexer [Char] -> Lexer MisoString
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 MisoString -> Lexer Bool
forall a b. a -> Lexer b -> Lexer a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ MisoString -> Lexer MisoString
string MisoString
"false"
  , Bool
True Bool -> Lexer MisoString -> Lexer Bool
forall a b. a -> Lexer b -> Lexer a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ MisoString -> Lexer MisoString
string MisoString
"true"
  ]
----------------------------------------------------------------------------
string' :: Lexer MisoString
string' :: Lexer MisoString
string' = Char -> Lexer Char
char Char
'"' Lexer Char -> Lexer MisoString -> Lexer MisoString
forall a b. Lexer a -> Lexer b -> Lexer b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ([Char] -> MisoString
forall str. ToMisoString str => str -> MisoString
toMisoString ([Char] -> MisoString) -> Lexer [Char] -> Lexer MisoString
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 MisoString -> Lexer Char -> Lexer MisoString
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
    escapedCharacter :: Lexer Char
escapedCharacter = Char -> Lexer Char
char Char
'\\' Lexer Char -> Lexer Char -> Lexer Char
forall a b. Lexer a -> Lexer b -> Lexer b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f 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'
      , do
          a <- Lexer Char
hexDigit
          b <- hexDigit
          c <- hexDigit
          d <- hexDigit
          maybe oops (pure . chr . fst)
              . listToMaybe
              . readHex
              $ [a, b, c, d]
      ]
----------------------------------------------------------------------------
null :: Lexer ()
null :: Lexer ()
null = Lexer MisoString -> Lexer ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (MisoString -> Lexer MisoString
string MisoString
"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
  , MisoString -> Token
TokenString (MisoString -> Token) -> Lexer MisoString -> Lexer Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lexer MisoString
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
  ]
----------------------------------------------------------------------------
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)
----------------------------------------------------------------------------