git.iko.soy/elk
on 00a3069 help sign in
elk/src/Json/Decode.hs
267 lines 6.2 kB history raw
1{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2{-# LANGUAGE BangPatterns, MagicHash, OverloadedStrings, UnboxedTuples #-}
3module Json.Decode
4 ( parse
5 -- re-export from Json.Decode.Internals
6 , Json.Decoder, Json.Error(..)
7 , Json.string, Json.text, Json.bool, Json.int
8 , Json.list, Json.dict, Json.maybe
9 , Json.field, Json.at
10 , Json.index
11 , Json.map, Json.map2
12 , Json.succeed, Json.fail
13 , Json.andThen, Json.oneOf
14 )
15 where
18import Prelude hiding (length)
19import qualified Data.ByteString.Internal as B
20import qualified Data.HashMap.Strict as HashMap
21import qualified Data.Text as Text
22import qualified Data.Text.Encoding as Text
23import qualified Data.Vector as Vector
24import Foreign.ForeignPtr (ForeignPtr)
25import GHC.Word (Word8(..))
27import qualified Json.Decode.Internals as Json
28import qualified Parse.Primitives as P
29import qualified Parse.Primitives.Internals as I
30import Parse.Primitives.Internals (Parser(..), State(..), noError)
31import qualified Parse.Primitives.Keyword as Keyword
32import qualified Parse.Primitives.Symbol as Symbol
33import qualified Reporting.Error.Syntax as E
34import qualified Reporting.Region as R
38-- PARSE
41data Result e a
42 = BadJson E.Error
43 | BadContent (Json.Error e)
44 | Success a
47parse :: Json.Decoder e a -> B.ByteString -> Result e a
48parse (Json.Decoder run) bytestring =
49 case P.run jsonFile bytestring of
50 Left err ->
51 BadJson err
53 Right value ->
54 case run id value of
55 Left err ->
56 BadContent err
58 Right answer ->
59 Success answer
63-- JSON
66jsonFile :: Parser Json.Value
67jsonFile =
68 do spaces
69 value <- jsonValue
70 spaces
71 P.endOfFile
72 return value
75jsonValue :: Parser Json.Value
76jsonValue =
77 do start <- P.getPosition
78 I.oneOf
79 [ Json.String <$> string
80 , object start
81 , array start
82 , number
83 , Keyword.jsonTrue >> return Json.TRUE
84 , Keyword.jsonFalse >> return Json.FALSE
85 , Keyword.jsonNull >> return Json.NULL
86 ]
90-- OBJECT
93object :: R.Position -> Parser Json.Value
94object start =
95 do Symbol.leftCurly
96 P.inContext start E.ExprRecord $
97 do spaces
98 I.oneOf
99 [ do entry <- field
100 spaces
101 objectHelp [entry]
102 , do Symbol.rightCurly
103 return (Json.Object [] HashMap.empty)
104 ]
107objectHelp :: [(Text.Text, Json.Value)] -> Parser Json.Value
108objectHelp revEntries =
109 I.oneOf
110 [
111 do Symbol.comma
112 spaces
113 entry <- field
114 spaces
115 objectHelp (entry:revEntries)
116 ,
117 do Symbol.rightCurly
118 return (Json.Object (reverse revEntries) (HashMap.fromList revEntries))
119 ]
122field :: Parser (Text.Text, Json.Value)
123field =
124 do key <- string
125 spaces
126 Symbol.hasType
127 spaces
128 value <- jsonValue
129 return (key, value)
133-- ARRAY
136array :: R.Position -> Parser Json.Value
137array start =
138 do Symbol.leftSquare
139 P.inContext start E.ExprList $
140 do spaces
141 I.oneOf
142 [ do entry <- jsonValue
143 spaces
144 arrayHelp 1 [entry]
145 , do Symbol.rightSquare
146 return (Json.Array Vector.empty)
147 ]
150arrayHelp :: Int -> [Json.Value] -> Parser Json.Value
151arrayHelp !length revEntries =
152 I.oneOf
153 [
154 do Symbol.comma
155 spaces
156 entry <- jsonValue
157 spaces
158 arrayHelp (length + 1) (entry:revEntries)
159 ,
160 do Symbol.rightSquare
161 return $ Json.Array $ Vector.reverse $
162 Vector.fromListN length revEntries
163 ]
167-- NUMBER
170number :: Parser Json.Value
171number =
172 error "TODO"
176-- STRING
179string :: Parser Text.Text
180string =
181 Parser $ \(State fp offset terminal indent row col ctx) cok cerr _ eerr ->
182 if offset < terminal && I.unsafeIndex fp offset == 0x22 {- " -} then
184 case stringHelp fp (offset + 1) terminal row (col + 1) of
185 Err err ->
186 cerr err
188 Ok newOffset newRow newCol ->
189 let
190 !newState = State fp newOffset terminal indent newRow newCol ctx
191 !content = Text.decodeUtf8 (B.PS fp offset (newOffset - offset))
192 in
193 cok content newState noError
195 else
196 eerr noError
199data StringResult
200 = Err E.ParseError
201 | Ok !Int !Int !Int
204stringHelp :: ForeignPtr Word8 -> Int -> Int -> Int -> Int -> StringResult
205stringHelp fp offset terminal row col =
206 if offset >= terminal then
207 Err (E.ParseError row col E.EndOfFile_String)
209 else
210 case I.unsafeIndex fp offset of
211 0x22 {- " -} ->
212 Ok (offset + 1) row (col + 1)
214 0x0A {- \n -} ->
215 Err (E.ParseError row col E.NewLineInString)
217 0x5C {- \ -} ->
218 let
219 !offset1 = offset + 1
220 in
221 if offset1 < terminal then
223 let
224 !word = I.unsafeIndex fp offset1
225 !newOffset = offset1 + I.getCharWidth fp offset1 terminal word
226 in
227 stringHelp fp newOffset terminal row (col + 2)
229 else
230 Err (E.ParseError (row + 1) col E.EndOfFile_String)
232 word ->
233 let !newOffset = offset + I.getCharWidth fp offset terminal word in
234 stringHelp fp newOffset terminal row (col + 1)
239-- SPACES
242spaces :: Parser ()
243spaces =
244 Parser $ \(State fp offset terminal indent row col ctx) cok _ _ _ ->
245 let
246 (# newOffset, newRow, newCol #) =
247 eatSpaces fp offset terminal row col
249 !newState =
250 State fp newOffset terminal indent newRow newCol ctx
251 in
252 cok () newState noError
255eatSpaces :: ForeignPtr Word8 -> Int -> Int -> Int -> Int -> (# Int, Int, Int #)
256eatSpaces fp offset terminal row col =
257 if offset >= terminal then
258 (# offset, row, col #)
260 else
261 case I.unsafeIndex fp offset of
262 0x20 {- -} -> eatSpaces fp (offset + 1) terminal row (col + 1)
263 0x09 {- \t -} -> eatSpaces fp (offset + 1) terminal row (col + 1)
264 0x0A {- \n -} -> eatSpaces fp (offset + 1) terminal (row + 1) 1
265 0x0D {- \r -} -> eatSpaces fp (offset + 1) terminal row col
266 _ ->
267 (# offset, row, col #)