217 lines
5 KiB
Markdown
217 lines
5 KiB
Markdown
# JSON Parser
|
|
|
|
```idris
|
|
module Parser.JSON
|
|
|
|
import public Parser
|
|
import public Parser.Numbers
|
|
|
|
import Structures.Dependent.DList
|
|
```
|
|
|
|
<!-- idris
|
|
import System
|
|
import Derive.Prelude
|
|
import Generics.Derive
|
|
|
|
%hide Generics.Derive.Eq
|
|
%hide Generics.Derive.Ord
|
|
%hide Generics.Derive.Show
|
|
|
|
%language ElabReflection
|
|
-->
|
|
|
|
## JSON components
|
|
|
|
Types a JSON value is allowed to have
|
|
|
|
```idris
|
|
public export
|
|
data JSONType : Type where
|
|
TObject : JSONType
|
|
TArray : JSONType
|
|
TString : JSONType
|
|
TNumber : JSONType
|
|
TBool : JSONType
|
|
TNull : JSONType
|
|
%runElab derive "JSONType" [Generic, Meta, Eq, Ord, Show, DecEq]
|
|
%name JSONType type, type2, type3
|
|
```
|
|
|
|
A JSON value indexed by its type
|
|
|
|
```idris
|
|
public export
|
|
data JSONValue : JSONType -> Type where
|
|
VObject : {types : List JSONType}
|
|
-> DList JSONType (\t => (String, JSONValue t)) types -> JSONValue TObject
|
|
VArray : {types : List JSONType}
|
|
-> DList JSONType JSONValue types -> JSONValue TArray
|
|
VString : (s : String) -> JSONValue TString
|
|
VNumber : (d : Double) -> JSONValue TNumber
|
|
VBool : (b : Bool) -> JSONValue TBool
|
|
VNull : JSONValue TNull
|
|
%name JSONValue value, value2, value3
|
|
```
|
|
|
|
<!-- idris
|
|
Show (JSONValue t) where
|
|
show (VObject xs) =
|
|
let xs = dMap (\_,(key, value) => "\"\{key}\":\{show value}") xs
|
|
in assert_total $ "{\{joinBy "," xs}}"
|
|
show (VArray xs) =
|
|
let xs = dMap (\_,e => show e) xs
|
|
in assert_total $ "[\{joinBy "," . map show $ xs}]"
|
|
show (VString s) = "\"\{s}\""
|
|
show (VNumber d) = show d
|
|
show (VBool False) = "false"
|
|
show (VBool True) = "true"
|
|
show VNull = "null"
|
|
|
|
%hide Language.Reflection.TT.WithFC.value
|
|
-->
|
|
|
|
## Parsers
|
|
|
|
We are going to get mutually recursive here. Instead of using a `mutual` block,
|
|
we will use the more modern style of declaring all our types ahead of our
|
|
definitions.
|
|
|
|
```idris
|
|
export
|
|
object : Parser (JSONValue TObject)
|
|
export
|
|
array : Parser (JSONValue TArray)
|
|
export
|
|
string : Parser (JSONValue TString)
|
|
export
|
|
number : Parser (JSONValue TNumber)
|
|
export
|
|
bool : Parser (JSONValue TBool)
|
|
export
|
|
null : Parser (JSONValue TNull)
|
|
```
|
|
|
|
Define a `whitespace` character class based on the json specifications
|
|
|
|
```idris
|
|
whitespace : Parser Char
|
|
whitespace = do
|
|
result <-
|
|
parseChar (\x => any (== x) $ the (List _) [' ', '\n', '\r', '\t']) id
|
|
case result of
|
|
GotChar char => pure char
|
|
GotError err => throwParseError "Expected whitespace, got: \{show err}"
|
|
EndOfInput => throwParseError "End of Input"
|
|
```
|
|
|
|
Convenience function
|
|
|
|
```idris
|
|
dpairize : {t : JSONType} ->
|
|
Parser (JSONValue t) -> Parser (t' : JSONType ** JSONValue t')
|
|
dpairize x = do
|
|
x <- x
|
|
pure (_ ** x)
|
|
```
|
|
|
|
Top level json value parser
|
|
|
|
```idris
|
|
export
|
|
value : Parser (t : JSONType ** JSONValue t)
|
|
value = do
|
|
_ <- many whitespace
|
|
val <- oneOfE
|
|
(throwParseError "Expected JSON Value")
|
|
(the (List _)
|
|
[
|
|
dpairize object
|
|
, dpairize array
|
|
, dpairize string
|
|
, dpairize number
|
|
, dpairize bool
|
|
, dpairize null
|
|
])
|
|
_ <- many whitespace
|
|
pure val
|
|
```
|
|
|
|
Now go through our json value types
|
|
|
|
```idris
|
|
object = do
|
|
oneOfE
|
|
(throwParseError "Expected Object")
|
|
(the (List _) [emptyObject, occupiedObject])
|
|
where
|
|
emptyObject : Parser (JSONValue TObject)
|
|
emptyObject = do
|
|
_ <- parseExactChar '{'
|
|
_ <- many whitespace
|
|
_ <- parseExactChar '}'
|
|
pure $ VObject Nil
|
|
firstKeyValue : Parser (t : JSONType ** (String, JSONValue t))
|
|
firstKeyValue = do
|
|
_ <- many whitespace
|
|
VString key <- string
|
|
_ <- many whitespace
|
|
_ <- parseExactChar ':'
|
|
(typ ** val) <- value
|
|
pure (typ ** (key, val))
|
|
restKeyValue : Parser (t : JSONType ** (String, JSONValue t))
|
|
restKeyValue = do
|
|
_ <- parseExactChar ','
|
|
firstKeyValue
|
|
occupiedObject : Parser (JSONValue TObject)
|
|
occupiedObject = do
|
|
_ <- parseExactChar '{'
|
|
first <- firstKeyValue
|
|
rest <- many restKeyValue
|
|
_ <- parseExactChar '}'
|
|
let (types ** xs) = DList.fromList (first :: rest)
|
|
pure $ VObject xs
|
|
```
|
|
|
|
```idris
|
|
array = do
|
|
oneOfE
|
|
(throwParseError "Expected Array")
|
|
(the (List _) [emptyArray, occupiedArray])
|
|
where
|
|
emptyArray : Parser (JSONValue TArray)
|
|
emptyArray = do
|
|
_ <- parseExactChar '['
|
|
_ <- many whitespace
|
|
_ <- parseExactChar ']'
|
|
pure $ VArray Nil
|
|
restValue : Parser (t : JSONType ** JSONValue t)
|
|
restValue = do
|
|
_ <- parseExactChar ','
|
|
value
|
|
occupiedArray : Parser (JSONValue TArray)
|
|
occupiedArray = do
|
|
_ <- parseExactChar '['
|
|
first <- value
|
|
rest <- many restValue
|
|
_ <- parseExactChar ']'
|
|
let (types ** xs) = DList.fromList (first :: rest)
|
|
pure $ VArray xs
|
|
```
|
|
|
|
```idris
|
|
string = do
|
|
_ <- parseExactChar '"'
|
|
-- TODO: Handle control characters properly
|
|
e1 <- parseError "Expected non-quote, got quote"
|
|
e2 <- parseError "End of input"
|
|
contents <- parseString . many $ parseCharE (not . (== '"')) (\_ => e1) e2
|
|
_ <- parseExactChar '"'
|
|
pure $ VString contents
|
|
```
|
|
|
|
```idris
|
|
number = do
|
|
d <- double
|
|
pure $ VNumber d
|
|
```
|