{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing #-}
{-# LANGUAGE BangPatterns, Rank2Types, MagicHash, OverloadedStrings, UnboxedTuples, TypeSynonymInstances #-}
{-# LANGUAGE PackageImports #-}
{-|
Module : Json.Decode
Description : Decode JSON.
License : BSD 3
Maintainer : terezasokol@gmail.com
Stability : experimental
Portability : POSIX
-}
module Json.Decode
( -- Turn JSON values into Haskell values.
-- * Primitives
Decoder
, string
, bool
, int
, float
, null
, succeed
, fail
-- * Data Structures
, nullable
, list
, oneOrMore
, dict
, pair
, field
, at
-- * Inconsistent Data Structure
, maybe
, oneOf
-- * Run Decoders
, fromString
, fromFile
, Error(..)
, Problem(..)
, DecodeExpectation(..)
, ParseError(..)
, errorToString
-- * Transforming
, map, map2, map3, map4, map5, map6, map7, map8, andThen
)
where
import qualified Data.List as List hiding (map)
import qualified "text-utf8" Data.Text.IO
import qualified Parser as P
import qualified String
import qualified Dict
import qualified Json.String as JS
import qualified Internal.Task
import GHC.Prim (ByteArray#)
import GHC.Word (Word8)
import Basics ((++), Float, (<|))
import Dict (Dict)
import List (List)
import Parser (Pos, End, Row, Col)
import Result (Result(..))
import String (String)
import Maybe (Maybe(..))
import Task (Task)
import Prelude hiding ((++), Float, String, Maybe(..), maybe, map, fail, null)
-- RUNNERS
{-| Parse the given string into a JSON value and then run the `Decoder` on it.
This will fail if the string is not well-formed JSON or if the `Decoder`
fails for some reason.
> fromString int "4" == Ok 4
> fromString int "1 + 2" == Err ...
-}
fromString :: Decoder a -> String -> Result Error a
fromString (Decoder decode) src =
case P.fromString pFile BadEnd src of
Ok ast ->
decode ast Ok (Err . DecodeProblem)
Err problem ->
Err (ParseProblem problem)
{-| -}
fromFile :: Decoder a -> String -> Task Error a
fromFile decoder file =
Internal.Task.Task <| do
content <- Data.Text.IO.readFile (String.toList file)
let src = String.fromTextUtf8 content
return (fromString decoder src)
-- DECODERS
{-| A value that knows how to decode JSON values.
-}
newtype Decoder a =
Decoder (forall b. AST -> (a -> b) -> (Problem -> b) -> b)
data AST
= Array (List AST)
| Object (List (String, AST))
| String String
| Int Int
| Float Float
| Boolean Bool
| NULL
-- ERRORS
{-| A structured error describing exactly how the decoder failed. You can use
this to create more elaborate visualizations of a decoder problem. For example,
you could show the entire JSON object and show the part causing the failure in
red.
-}
data Error
= DecodeProblem Problem
| ParseProblem ParseError
deriving (Eq, Show)
-- DECODE PROBLEMS
data Problem
= Field String Problem
| Index Int Problem
| OneOf Problem [Problem]
| Failure String
| Expecting DecodeExpectation
deriving (Eq, Show)
{-| -}
data DecodeExpectation
= TObject
| TArray
| TString
| TBool
| TInt
| TFloat
| TObjectWith String
| TArrayPair Int
| TNull
deriving (Eq, Show)
-- ERROR TO STRING
{-| Convert a decoding error into a `String` that is nice for debugging.
This function is WORK IN PROGRESS and frankly not very good yet.
-}
errorToString :: Error -> String
errorToString error =
case error of
DecodeProblem problem ->
case problem of
Field field _ ->
"Could not decode field " ++ field ++ "."
Index i _ ->
"Errored at array index " ++ String.fromList (show i) ++ "."
OneOf _ _ ->
"Could not find any solutions in oneOf"
Failure msg ->
msg
Expecting expecting ->
case expecting of
TObject ->
"Expected an object."
TArray ->
"Expected an array."
TString ->
"Expected a string."
TBool ->
"Expected a boolean."
TInt ->
"Expected an int."
TFloat ->
"Expected a float."
TObjectWith field ->
"Expected an object with a property \"" ++ field ++ "\"."
TArrayPair _ ->
"Expected an array of two elements."
TNull ->
"Expected a null."
ParseProblem _ ->
"Parser problem TODO"
-- INSTANCES
instance Functor Decoder where
{-# INLINE fmap #-}
fmap func (Decoder decodeA) =
Decoder $ \ast ok err ->
let
ok' a = ok (func a)
in
decodeA ast ok' err
instance Applicative Decoder where
{-# INLINE pure #-}
pure = return
{-# INLINE (<*>) #-}
(<*>) (Decoder decodeFunc) (Decoder decodeArg) =
Decoder $ \ast ok err ->
let
okF func =
let
okA arg = ok (func arg)
in
decodeArg ast okA err
in
decodeFunc ast okF err
instance Monad Decoder where
{-# INLINE return #-}
return a =
Decoder $ \_ ok _ ->
ok a
{-# INLINE (>>=) #-}
(>>=) (Decoder decodeA) callback =
Decoder $ \ast ok err ->
let
ok' a =
case callback a of
Decoder decodeB -> decodeB ast ok err
in
decodeA ast ok' err
-- STRINGS
{-| Decode a JSON string into a `Text`.
> fromString string "true" == Err ...
> fromString string "42" == Err ...
> fromString string "3.14" == Err ...
> fromString string "\"hello\"" == Ok "hello"
> fromString string "{ \"hello\": 42 }" == Err ...
-}
string :: Decoder String
string =
Decoder $ \ast ok err ->
case ast of
String str ->
ok str
_ ->
err (Expecting TString)
-- BOOL
{-| Decode a JSON boolean into a `Prelude.Bool`.
> fromString bool "true" == Ok True
> fromString bool "42" == Err ...
> fromString bool "3.14" == Err ...
> fromString bool "\"hello\"" == Err ...
> fromString bool "{ \"hello\": 42 }" == Err ...
-}
bool :: Decoder Bool
bool =
Decoder $ \ast ok err ->
case ast of
Boolean boolean ->
ok boolean
_ ->
err (Expecting TBool)
-- INT
{-| Decode a JSON number into an `Prelude.Int`.
> fromString int "true" == Err ...
> fromString int "42" == Ok 42
> fromString int "3.14" == Err ...
> fromString int "\"hello\"" == Err ...
> fromString int "{ \"hello\": 42 }" == Err ...
-}
int :: Decoder Int
int =
Decoder $ \ast ok err ->
case ast of
Int n ->
ok n
_ ->
err (Expecting TInt)
-- FLOAT
{-| Decode a JSON number into a `Prelude.Float`.
> fromString float "true" == Err ..
> fromString float "42" == Ok 42
> fromString float "3.14" == Ok 3.14
> fromString float "\"hello\"" == Err ...
> fromString float "{ \"hello\": 42 }" == Err ...
-}
float :: Decoder Float
float =
Decoder $ \ast ok err ->
case ast of
Float n ->
ok n
_ ->
err (Expecting TFloat)
-- NULL
{-| Decode a nullable JSON value into a value.
> fromString (nullable int) "13" == Ok (Just 13)
> fromString (nullable int) "42" == Ok (Just 42)
> fromString (nullable int) "null" == Ok Nothing
> fromString (nullable int) "true" == Err ..
-}
nullable :: Decoder a -> Decoder (Maybe a)
nullable decoder =
oneOf
[ fmap Just decoder
, null_
]
null_ :: Decoder (Maybe a)
null_ =
Decoder $ \ast ok err ->
case ast of
NULL ->
ok Nothing
_ ->
err (Expecting TNull)
{-| Decode a `null` value into some value.
> fromString (null False) "null" == Ok False
> fromString (null 42) "null" == Ok 42
> fromString (null 42) "42" == Err ..
> fromString (null 42) "false" == Err ..
So if you ever see a `null`, this will return whatever value you specified.
-}
null :: a -> Decoder a
null value =
Decoder $ \ast ok err ->
case ast of
NULL ->
ok value
_ ->
err (Expecting TNull)
-- MAYBE
{-| Helpful for dealing with optional fields. Here are a few slightly different
examples:
> json = """{ "name": "tom", "age": 42 }"""
> fromString (maybe (field "age" int )) json == Ok (Just 42)
> fromString (maybe (field "name" int )) json == Ok Nothing
> fromString (maybe (field "height" float)) json == Ok Nothing
> fromString (field "age" (maybe int )) json == Ok (Just 42)
> fromString (field "name" (maybe int )) json == Ok Nothing
> fromString (field "height" (maybe float)) json == Err ...
Notice the last example! It is saying we *must* have a field named `height` and
the content *may* be a float. There is no `height` field, so the decoder fails.
Point is, `maybe` will make exactly what it contains conditional. For optional
fields, this means you probably want it *outside* a use of `field` or `at`.
-}
maybe :: Decoder a -> Decoder (Maybe a)
maybe decoder_ =
oneOf
[ fmap Just decoder_
, return Nothing
]
-- LISTS
{-| Decode a JSON array into a `List`.
> fromString (list int) "[1,2,3]" == Ok [1,2,3]
> fromString (list bool) "[true,false]" == Ok [True,False]
-}
list :: Decoder a -> Decoder [a]
list decoder =
Decoder $ \ast ok err ->
case ast of
Array asts ->
listHelp decoder ok err 0 asts []
_ ->
err (Expecting TArray)
listHelp :: Decoder a -> ([a] -> b) -> (Problem -> b) -> Int -> [AST] -> [a] -> b
listHelp decoder@(Decoder decodeA) ok err !i asts revs =
case asts of
[] ->
ok (List.reverse revs)
ast:asts ->
let
ok' value = listHelp decoder ok err (i+1) asts (value:revs)
err' prob = err (Index i prob)
in
decodeA ast ok' err'
-- PAIR
{-| Decode a JSON array of exactly two elements into a `Tuple`.
> fromString (pair int book) "[1, false]" == Ok (1, false)
> fromString (pair int bool) "[1, false, 3]" == Err ..
-}
pair :: Decoder a -> Decoder b -> Decoder ( a, b )
pair (Decoder decodeA) (Decoder decodeB) =
Decoder $ \ast ok err ->
case ast of
Array vs ->
case vs of
[astA,astB] ->
let
err0 e = err (Index 0 e)
ok0 a =
let
err1 e = err (Index 1 e)
ok1 b = ok (a,b)
in
decodeB astB ok1 err1
in
decodeA astA ok0 err0
_ ->
err (Expecting (TArrayPair (List.length vs)))
_ ->
err (Expecting TArray)
-- OBJECTS
{-| Decode a JSON object into an `Dict`.
> fromString (dict int) "{ \"alice\": 42, \"bob\": 99 }"
> == Ok (Dict.fromList [("alice", 42), ("bob", 99)])
If you need the keys (like `alice` and `bob`) available in the `Dict`
values as well, I recommend using a (private) intermediate data structure like
`Info` in this example:
> module User exposing (User, decoder)
>
> import Dict
> import Json.Decode exposing (..)
>
> type alias User =
> { name : String
> , height : Float
> , age : Int
> }
>
> decoder : Decoder (Dict.Dict String User)
> decoder =
> map (Dict.map infoToUser) (dict infoDecoder)
>
> type alias Info =
> { height : Float
> , age : Int
> }
>
> infoDecoder : Decoder Info
> infoDecoder =
> map2 Info
> (field "height" float)
> (field "age" int)
>
> infoToUser : String -> Info -> User
> infoToUser name { height, age } =
> User name height age
So now JSON like
> { "alice": { height: 1.6, age: 33 }}
are turned into dictionary values like
> Dict.singleton "alice" (User "alice" 1.6 33)
if you need that.
-}
dict :: Decoder a -> Decoder (Dict String a)
dict valueDecoder =
map Dict.fromList (pairs valueDecoder)
pairs :: Decoder a -> Decoder [( String, a )]
pairs valueDecoder =
Decoder $ \ast ok err ->
case ast of
Object kvs ->
pairsHelp valueDecoder ok err kvs []
_ ->
err (Expecting TObject)
pairsHelp :: Decoder a -> ([( String, a )] -> b) -> (Problem -> b) -> [( String, AST )] -> [( String, a )] -> b
pairsHelp valueDecoder@(Decoder decodeA) ok err kvs revs =
case kvs of
[] ->
ok (List.reverse revs)
( key, ast ) : kvs ->
let
ok' value = pairsHelp valueDecoder ok err kvs (( key, value ) : revs)
err' prob = err (Field key prob)
in
decodeA ast ok' err'
{-| Decode a JSON array that has one or more elements.
-}
oneOrMore :: (a -> [a] -> value) -> Decoder a -> Decoder value
oneOrMore toValue decoder =
list decoder >>= oneOrMoreHelp toValue
oneOrMoreHelp :: (a -> [a] -> value) -> [a] -> Decoder value
oneOrMoreHelp toValue xs =
case xs of
[] ->
fail "a ARRAY with at least ONE element"
y : ys ->
succeed (toValue y ys)
-- FIELDS
{-| Decode a JSON object, requiring a particular field.
> fromString (field "x" int) "{ \"x\": 3 }" == Ok 3
> fromString (field "x" int) "{ \"x\": 3, \"y\": 4 }" == Ok 3
> fromString (field "x" int) "{ \"x\": true }" == Err ...
> fromString (field "x" int) "{ \"y\": 4 }" == Err ...
> fromString (field "name" string) "{ \"name\": \"tom\" }" == Ok "tom"
The object *can* have other fields. Lots of them! The only thing this decoder
cares about is if `x` is present and that the value there is an `Int`.
Check out [`map2`](#map2) to see how to decode multiple fields!
-}
field :: String -> Decoder a -> Decoder a
field key (Decoder decodeA) =
Decoder $ \ast ok err ->
case ast of
Object kvs ->
case findField key kvs of
Just value ->
let
err' prob =
err (Field key prob)
in
decodeA value ok err'
Nothing ->
err (Expecting (TObjectWith key))
_ ->
err (Expecting TObject)
findField :: String -> [( String, AST )] -> Maybe AST
findField key pairs =
case pairs of
[] ->
Nothing
(bts, value) : remainingPairs ->
if key == bts
then Just value
else findField key remainingPairs
{-| Decode a nested JSON object, requiring certain fields.
> json = """{ "person": { "name": "tom", "age": 42 } }"""
> fromString (at ["person", "name"] string) json == Ok "tom"
> fromString (at ["person", "age" ] int ) json == Ok "42
This is really just a shorthand for saying things like:
> field "person" (field "name" string) == at ["person","name"] string
-}
at :: [String] -> Decoder a -> Decoder a
at fields decoder =
List.foldr field decoder fields
-- ONE OF
{-| Try a bunch of different decoders. This can be useful if the JSON may come
in a couple different formats. For example, say you want to read an array of
numbers, but some of them are `null`.
> import String
>
> badInt : Decoder Int
> badInt =
> oneOf [ int, null 0 ]
>
> -- fromString (list badInt) "[1,2,null,4]" == Ok [1,2,0,4]
Why would someone generate JSON like this? Questions like this are not good
for your health. The point is that you can use `oneOf` to handle situations
like this!
You could also use `oneOf` to help version your data. Try the latest format,
then a few older ones that you still support. You could use `andThen` to be
even more particular if you wanted.
-}
oneOf :: [Decoder a] -> Decoder a
oneOf decoders =
Decoder $ \ast ok err ->
case decoders of
Decoder decodeA : decoders ->
let
err' e =
oneOfHelp ast ok err decoders e []
in
decodeA ast ok err'
[] ->
error "Ran into (Json.Decode.oneOf [])"
oneOfHelp :: AST -> (a -> b) -> (Problem -> b) -> [Decoder a] -> Problem -> [Problem] -> b
oneOfHelp ast ok err decoders p ps =
case decoders of
Decoder decodeA : decoders ->
let
err' p' =
oneOfHelp ast ok err decoders p' (p:ps)
in
decodeA ast ok err'
[] ->
err (oneOfError [] p ps)
oneOfError :: [Problem] -> Problem -> [Problem] -> Problem
oneOfError problems prob ps =
case ps of
[] ->
OneOf prob problems
p:ps ->
oneOfError (prob:problems) p ps
-- PRIMITIVES
{-| Ignore the JSON and make the decoder fail. This is handy when used with
`oneOf` or `andThen` where you want to give a custom error message in some
case.
See the [`andThen`](#andThen) docs for an example.
-}
fail :: String -> Decoder a
fail x =
Decoder $ \_ _ err ->
err (Failure x)
{-| Ignore the JSON and produce a certain value.
> fromString (succeed 42) "true" == Ok 42
> fromString (succeed 42) "[1,2,3]" == Ok 42
> fromString (succeed 42) "hello" == Err ... -- this is not a valid JSON string
This is handy when used with `oneOf` or `andThen`.
-}
succeed :: a -> Decoder a
succeed a =
Decoder $ \_ ok _ ->
ok a
-- MAPS
{-| Transform a decoder. Maybe you just want to know the length of a string:
> import String
>
> stringLength : Decoder Int
> stringLength =
> map String.length string
It is often helpful to use `map` with `oneOf`, like when defining `nullable`:
nullable : Decoder a -> Decoder (Maybe a)
nullable decoder =
oneOf
[ null Nothing
, map Just decoder
]
-}
map :: (a -> value) -> Decoder a -> Decoder value
map f a =
return f <*> a
{-| Try two decoders and then combine the result. We can use this to decode
objects with many fields:
> type alias Point = { x : Float, y : Float }
>
> point : Decoder Point
> point =
> map2 Point
> (field "x" float)
> (field "y" float)
>
> -- fromString point """{ "x": 3, "y": 4 }""" == Ok { x = 3, y = 4 }
It tries each individual decoder and puts the result together with the `Point`
constructor.
-}
map2 :: (a -> b -> value) -> Decoder a -> Decoder b -> Decoder value
map2 func a b =
return func <*> a <*> b
{-| Try three decoders and then combine the result. We can use this to decode
objects with many fields:
> type alias Person = { name : String, age : Int, height : Float }
>
> person : Decoder Person
> person =
> map3 Person
> (at ["name"] string)
> (at ["info","age"] int)
> (at ["info","height"] float)
>
> -- json = """{ "name": "tom", "info": { "age": 42, "height": 1.8 } }"""
> -- fromString person json == Ok { name = "tom", age = 42, height = 1.8 }
Like `map2` it tries each decoder in order and then give the results to the
`Person` constructor. That can be any function though!
-}
map3 :: (a -> b -> c -> value) -> Decoder a -> Decoder b -> Decoder c -> Decoder value
map3 func a b c =
return func <*> a <*> b <*> c
{-| -}
map4 :: (a -> b -> c -> d -> value) -> Decoder a -> Decoder b -> Decoder c -> Decoder d -> Decoder value
map4 func a b c d =
return func <*> a <*> b <*> c <*> d
{-| -}
map5 :: (a -> b -> c -> d -> e -> value) -> Decoder a -> Decoder b -> Decoder c -> Decoder d -> Decoder e -> Decoder value
map5 func a b c d e =
return func <*> a <*> b <*> c <*> d <*> e
{-| -}
map6 :: (a -> b -> c -> d -> e -> f -> value) -> Decoder a -> Decoder b -> Decoder c -> Decoder d -> Decoder e -> Decoder f -> Decoder value
map6 func a b c d e f =
return func <*> a <*> b <*> c <*> d <*> e <*> f
{-| -}
map7 :: (a -> b -> c -> d -> e -> f -> g -> value) -> Decoder a -> Decoder b -> Decoder c -> Decoder d -> Decoder e -> Decoder f -> Decoder g -> Decoder value
map7 func a b c d e f g =
return func <*> a <*> b <*> c <*> d <*> e <*> f <*> g
{-| -}
map8 :: (a -> b -> c -> d -> e -> f -> g -> h -> value) -> Decoder a -> Decoder b -> Decoder c -> Decoder d -> Decoder e -> Decoder f -> Decoder g -> Decoder h -> Decoder value
map8 func a b c d e f g h =
return func <*> a <*> b <*> c <*> d <*> e <*> f <*> g <*> h
{-| Create decoders that depend on previous results. If you are creating
versioned data, you might do something like this:
> info : Decoder Info
> info =
> field "version" int
> |> andThen infoHelp
>
> infoHelp : Int -> Decoder Info
> infoHelp version =
> case version of
> 4 ->
> infoDecoder4
>
> 3 ->
> infoDecoder3
>
> _ ->
> fail <|
> "Trying to decode info, but version "
> ++ toString version ++ " is not supported."
>
> -- infoDecoder4 : Decoder Info
> -- infoDecoder3 : Decoder Info
-}
andThen :: (a -> Decoder b) -> Decoder a -> Decoder b
andThen callback (Decoder decodeA) =
Decoder $ \ast ok err ->
let
ok' a =
case callback a of
Decoder decodeB -> decodeB ast ok err
in
decodeA ast ok' err
-- PARSE
type Parser a =
P.Parser ParseError a
data ParseError
= ObjectStart Row Col
| ObjectMore Row Col
| ObjectEnd Row Col
| ArrayStart Row Col
| ArrayMore Row Col
| ArrayEnd Row Col
| StringStart Row Col
| StringProblem StringProblem Row Col
| NumberStart Row Col
| NumberProblem NumberProblem Row Col
| Bool Row Col
| Null Row Col
| Value Row Col
| Colon Row Col
| BadEnd Row Col
deriving (Eq, Show)
data StringProblem
= BadStringEnd
| BadStringControlChar
| BadStringEscapeChar
| BadStringEscapeHex
deriving (Eq, Show)
data NumberProblem
= NumberEnd
| NumberDot Int
| NumberNoLeadingZero
deriving (Eq, Show)
-- PARSE AST
pFile :: Parser AST
pFile =
do spaces
value <- pValue
spaces
return value
pValue :: Parser AST
pValue =
P.oneOf Value
[ String <$> pString
, pObject
, pArray
, P.symbol 0x2B {- + -} NumberStart >> pNumber id id
, P.symbol 0x2D {- - -} NumberStart >> pNumber negate negate
, pNumber id id
, P.k4 0x74 0x72 0x75 0x65 Bool >> return (Boolean True)
, P.k5 0x66 0x61 0x6C 0x73 0x65 Bool >> return (Boolean False)
, P.k4 0x6E 0x75 0x6C 0x6C Null >> return NULL
]
-- OBJECT
pObject :: Parser AST
pObject =
do P.word1 0x7B {- { -} ObjectStart
spaces
P.oneOf ObjectMore
[ do entry <- pField
spaces
pObjectHelp [entry]
, do P.word1 0x7D {-}-} ObjectEnd
return (Object [])
]
pObjectHelp :: [(String, AST)] -> Parser AST
pObjectHelp revEntries =
P.oneOf ObjectMore
[ do P.word1 0x2C {-,-} ObjectMore
spaces
entry <- pField
spaces
pObjectHelp (entry : revEntries)
,
do P.word1 0x7D {-}-} ObjectEnd
return (Object (List.reverse revEntries))
]
pField :: Parser (String, AST)
pField =
do key <- pString
spaces
P.word1 0x3A {-:-} Colon
spaces
value <- pValue
return (key, value)
-- ARRAY
pArray :: Parser AST
pArray =
do P.word1 0x5B {-[-} ArrayStart
spaces
P.oneOf ArrayMore
[ do entry <- pValue
spaces
pArrayHelp [entry]
, do P.word1 0x5D {-]-} ArrayEnd
return (Array [])
]
pArrayHelp :: [AST] -> Parser AST
pArrayHelp revEntries =
P.oneOf ArrayMore
[ do P.word1 0x2C {-,-} ArrayMore
spaces
entry <- pValue
spaces
pArrayHelp (entry:revEntries)
,
do P.word1 0x5D {-]-} ArrayEnd
return (Array (List.reverse revEntries))
]
-- STRING
pString :: Parser String
pString =
P.Parser $ \(P.State src pos end row col) cok _ cerr eerr ->
if pos < end && P.unsafeIndex src pos == 0x22 {-"-} then
let
!pos1 = pos + 1
!col1 = col + 1
(# status, newPos, newRow, newCol #) =
pStringHelp src pos1 end row col1 pos1 []
in
case status of
GoodString chunks ->
let
string = String.fromTextUtf8 (JS.toTextUtf8 src chunks)
!newState = P.State src newPos end newRow newCol
in
cok string newState
BadString problem ->
cerr newRow newCol (StringProblem problem)
else
eerr row col StringStart
data StringStatus
= GoodString [JS.Chunk]
| BadString StringProblem
pStringHelp :: ByteArray# -> Pos -> End -> Row -> Col -> Pos -> [JS.Chunk] -> (# StringStatus, Pos, Row, Col #)
pStringHelp src pos end row col initPos revChunks =
if pos >= end then
(# BadString BadStringEnd, pos, row, col #)
else
case P.unsafeIndex src pos of
0x22 {-"-} ->
(# GoodString (finalize initPos pos revChunks), pos + 1, row, col + 1 #)
0x0A {-\n-} ->
(# BadString BadStringEnd, pos, row, col #)
0x5C {-\-} ->
let !pos1 = pos + 1 in
if pos1 >= end then
(# BadString BadStringEnd, pos1, row + 1, col #)
else
case P.unsafeIndex src pos1 of
0x22 {-"-} -> pStringHelp src (pos + 2) end row (col + 2) (pos + 2) (addChunks (JS.Escape 0x22) initPos pos revChunks)
0x5C {-\-} -> pStringHelp src (pos + 2) end row (col + 2) (pos + 2) (addChunks (JS.Escape 0x5C) initPos pos revChunks)
0x2F {-/-} -> pStringHelp src (pos + 2) end row (col + 2) (pos + 2) (addChunks (JS.Escape 0x2F) initPos pos revChunks)
0x62 {-b-} -> pStringHelp src (pos + 2) end row (col + 2) (pos + 2) (addChunks (JS.Escape 0x08) initPos pos revChunks)
0x66 {-f-} -> pStringHelp src (pos + 2) end row (col + 2) (pos + 2) (addChunks (JS.Escape 0x0C) initPos pos revChunks)
0x6E {-n-} -> pStringHelp src (pos + 2) end row (col + 2) (pos + 2) (addChunks (JS.Escape 0x0A) initPos pos revChunks)
0x72 {-r-} -> pStringHelp src (pos + 2) end row (col + 2) (pos + 2) (addChunks (JS.Escape 0x0D) initPos pos revChunks)
0x74 {-t-} -> pStringHelp src (pos + 2) end row (col + 2) (pos + 2) (addChunks (JS.Escape 0x09) initPos pos revChunks)
0x75 {-u-} ->
let !pos6 = pos + 6 in
if end < pos6
then (# BadString BadStringEscapeHex, pos, row, col #)
else
let !code = getEscapedUtf16 src pos in
if code < 0
then (# BadString BadStringEscapeHex, pos, row, col #)
else
if code < 0xD800 || 0xDBFF < code
then
pStringHelp src pos6 end row (col + 6) pos6 $
addChunks (JS.CodePoint code) initPos pos revChunks
else
if 0xDBFF < code
then (# BadString BadStringEscapeHex, pos, row, col #)
else
let !pos12 = pos6 + 6 in
if pos12 <= end
&& P.unsafeIndex src (pos6 ) == 0x5C {-\-}
&& P.unsafeIndex src (pos6 + 1) == 0x75 {-u-}
then
let !pair = getEscapedUtf16 src pos6 in
if pair < 0 || pair < 0xDC00 || 0xDFFF < pair
then (# BadString BadStringEscapeHex, pos, row, col #)
else
let !point = 0x10000 + 0x400 * (code - 0xD800) + (pair - 0xDC00) in
pStringHelp src pos12 end row (col + 12) pos12 $
addChunks (JS.CodePoint point) initPos pos revChunks
else
(# BadString BadStringEscapeHex, pos, row, col #)
_ ->
(# BadString BadStringEscapeChar, pos, row, col #)
word ->
if word < 0x20 then
(# BadString BadStringControlChar, pos, row, col #)
else
let !newPos = pos + P.getCharWidth word in
pStringHelp src newPos end row (col + 1) initPos revChunks
finalize :: Int -> Int -> [JS.Chunk] -> [JS.Chunk]
finalize start end revChunks =
reverse $
if start == end then
revChunks
else
JS.Slice start (end - start) : revChunks
addChunks :: JS.Chunk -> Int -> Int -> [JS.Chunk] -> [JS.Chunk]
addChunks chunk start end revChunks =
if start == end then
chunk : revChunks
else
chunk : JS.Slice start (end - start) : revChunks
-- GET CODE
--
-- Will be negative for invalid encodings!
--
getEscapedUtf16 :: ByteArray# -> Int -> Int
getEscapedUtf16 src pos =
let
!d1 = toHex 1 (P.unsafeIndex src (pos + 2))
!d2 = toHex 16 (P.unsafeIndex src (pos + 3))
!d3 = toHex 256 (P.unsafeIndex src (pos + 4))
!d4 = toHex 4096 (P.unsafeIndex src (pos + 5))
in
d1 + d2 + d3 + d4
toHex :: Int -> Word8 -> Int
toHex factor word =
if 0x30 {-0-} <= word && word <= 0x39 {-9-} then
factor * fromIntegral (word - 0x30)
else if 0x61 {-a-} <= word && word <= 0x66 {-f-} then
factor * fromIntegral (word - 0x61)
else if 0x41 {-A-} <= word && word <= 0x46 {-F-} then
factor * fromIntegral (word - 0x41)
else
-65536
-- SPACES
spaces :: Parser ()
spaces =
P.Parser $ \state@(P.State src pos end row col) cok eok _ _ ->
let (# newPos, newRow, newCol #) = eatSpaces src pos end row col in
if pos == newPos then
eok () state
else
let !newState = P.State src newPos end newRow newCol in
cok () newState
eatSpaces :: ByteArray# -> Pos -> End -> Row -> Col -> (# Pos, Row, Col #)
eatSpaces src pos end row col =
if pos >= end then
(# pos, row, col #)
else
case P.unsafeIndex src pos of
0x20 {- -} -> eatSpaces src (pos + 1) end row (col + 1)
0x09 {-\t-} -> eatSpaces src (pos + 1) end row (col + 1)
0x0A {-\n-} -> eatSpaces src (pos + 1) end (row + 1) 1
0x0D {-\r-} -> eatSpaces src (pos + 1) end row col
_ ->
(# pos, row, col #)
-- NUMBERS
pNumber :: (Int -> Int) -> (Float -> Float) -> Parser AST
pNumber signInt signFloat =
P.Parser $ \(P.State src pos end row col) cok _ cerr eerr ->
if pos >= end then
eerr row col NumberStart
else
let !word = P.unsafeIndex src pos in
if not (isDecimalDigit word) then
eerr row col NumberStart
else
let
outcome =
let !pos1 = pos + 1 in
if word == 0x30 {-0-} then
chompZero src pos1 end
else
chompInt src pos1 end (toInt word)
in
case outcome of
BadOutcome newPos problem ->
let !newCol = col + fromIntegral (newPos - pos) in
cerr row newCol (NumberProblem problem)
OkInt newPos n ->
let !newCol = col + fromIntegral (newPos - pos)
!integer = Int (signInt n)
!newState = P.State src newPos end row newCol
in
cok integer newState
OkFloat newPos n ->
let !newCol = col + fromIntegral (newPos - pos)
!float = Float (signFloat n)
!newState = P.State src newPos end row newCol
in
cok float newState
-- CHOMP OUTCOME
data Outcome
= BadOutcome Pos NumberProblem
| OkInt Pos Int
| OkFloat Pos Float
-- CHOMP INT
chompInt :: ByteArray# -> Pos -> End -> Int -> Outcome
chompInt src !pos end !n =
if pos >= end then
OkInt pos n
else
let !word = P.unsafeIndex src pos in
if isDecimalDigit word then
let !pos1 = pos + 1 in
chompInt src pos1 end (10 * n + toInt word)
else if word == 0x2E {-.-} then
let !pos1 = pos + 1 in
chompFraction src pos1 end n
else if word == 0x65 {-e-} || word == 0x45 {-E-} then
chompExponent src (pos + 1) end (fromIntegral n)
else if isDirtyEnd src pos end word then
BadOutcome pos NumberEnd
else
OkInt pos n
-- CHOMP FRACTION
chompFraction :: ByteArray# -> Pos -> End -> Int -> Outcome
chompFraction src pos end !n =
if pos >= end then
BadOutcome pos (NumberDot n)
else
let !word1 = P.unsafeIndex src pos in
if isDecimalDigit word1 then
let !fraction = 1 / 10 * toFloat word1
!n' = fromIntegral n + fraction
!pos1 = pos + 1
in
chompFractionHelp src pos1 end (-2) n'
else
BadOutcome pos (NumberDot n)
chompFractionHelp :: ByteArray# -> Pos -> End -> Float -> Float -> Outcome
chompFractionHelp src pos end !power !n =
if pos >= end then
OkFloat pos n
else
let !word = P.unsafeIndex src pos in
if isDecimalDigit word then
let !fraction = (10 ** power) * toFloat word
!n' = n + fraction
in
chompFractionHelp src (pos + 1) end (power - 1) n'
else if word == 0x65 {-e-} || word == 0x45 {-E-} then
chompExponent src (pos + 1) end n
else if isDirtyEnd src pos end word then
BadOutcome pos NumberEnd
else
OkFloat pos n
-- CHOMP EXPONENT
chompExponent :: ByteArray# -> Pos -> End -> Float -> Outcome
chompExponent src pos end n =
if pos >= end then
BadOutcome pos NumberEnd
else
let !word = P.unsafeIndex src pos in
if isDecimalDigit word then
let !exponent = toInt word in
chompExponentHelp src (pos + 1) end exponent n
else if word == 0x2B {- + -} then
let !pos1 = pos + 1
!word1 = P.unsafeIndex src pos1
in
if pos1 < end && isDecimalDigit word1 then
let !exponent = toInt word1
!pos2 = pos + 2
in
chompExponentHelp src pos2 end exponent n
else
BadOutcome pos NumberEnd
else if word == 0x2D {- - -} then
let !pos1 = pos + 1
!word1 = P.unsafeIndex src pos1
in
if pos1 < end && isDecimalDigit word1 then
let !exponent = toInt word1
!pos2 = pos + 2
in
chompExponentHelp src pos2 end (negate exponent) n
else
BadOutcome pos NumberEnd
else
BadOutcome pos NumberEnd
chompExponentHelp :: ByteArray# -> Pos -> End -> Int -> Float -> Outcome
chompExponentHelp src pos end exponent n =
if pos >= end then
OkFloat pos (n * 10^exponent)
else
let !word = P.unsafeIndex src pos in
if isDecimalDigit word then
let !exponent' = 10 * exponent + toInt word
!pos1 = pos + 1
in
chompExponentHelp src pos1 end exponent' n
else
OkFloat pos (n * 10^exponent)
-- CHOMP ZERO
chompZero :: ByteArray# -> Pos -> End -> Outcome
chompZero src pos end =
if pos >= end then
OkInt pos 0
else
let !word = P.unsafeIndex src pos in
if word == 0x2E {-.-} then
let !pos1 = pos + 1 in
chompFraction src pos1 end 0
else if isDecimalDigit word then
BadOutcome pos NumberNoLeadingZero
else if isDirtyEnd src pos end word then
BadOutcome pos NumberEnd
else
OkInt pos 0
-- HELPERS
{-# INLINE isDecimalDigit #-}
isDecimalDigit :: Word8 -> Bool
isDecimalDigit word =
word <= 0x39 {-9-} && word >= 0x30 {-0-}
isDirtyEnd :: ByteArray# -> Pos -> End -> Word8 -> Bool
isDirtyEnd src pos end word =
P.getInnerWidthHelp src pos end word > 0
toInt :: Word8 -> Int
toInt word =
fromIntegral (word - 0x30 {-0-})
toFloat :: Word8 -> Float
toFloat word =
fromIntegral (word - 0x30 {-0-})