@@ -1,28 +1,52 @@
1+-- @inline Data.Argonaut.Core.caseJson always
12module PureScript.Backend.Optimizer.CoreFn.Json
23 ( decodeModule
34 , decodeModule'
45 , decodeAnn
56 ) where
67
7−import Prelude
8+import Prelude hiding (bind)
89
9−import Control.Alternative (guard, (<|>))
10+import Control.Alternative (guard)
1011import Control.Monad.Error.Class (throwError)
11−import Data.Argonaut (Json, JsonDecodeError(..), decodeJson)
12−import Data.Argonaut.Decode.Decoders (decodeArray, decodeBoolean, decodeInt, decodeJObject, decodeNumber, decodeString, decodeTuple, getField, getFieldOptional')
12+import Control.Monad.ST as ST
13+import Control.Monad.ST.Ref as STRef
14+import Data.Argonaut (Json, JsonDecodeError(..), caseJson, decodeJson, isNull)
1315import Data.Array as Array
14−import Data.Either (Either, note)
16+import Data.Array.ST as STArray
17+import Data.Either (Either(..), note)
1518import Data.Foldable (intercalate)
19+import Data.Int as Int
20+import Data.Maybe (Maybe(..))
1621import Data.String.CodeUnits as SCU
1722import Data.Traversable (traverse)
18−import Data.Tuple (Tuple(..), uncurry)
23+import Data.Tuple (Tuple(..))
1924import Foreign.Object (Object)
2025import Foreign.Object as Object
21−import PureScript.Backend.Optimizer.CoreFn (Ann(..), Bind(..), Binder(..), Binding(..), CaseAlternative(..), CaseGuard(..), Comment(..), ConstructorType(..), Expr(..), Guard(..), Ident(..), Import(..), Literal(..), Meta(..), Module(..), ModuleName(..), Prop(..), ProperName(..), Qualified(..), ReExport(..), SourcePos, SourceSpan)
26+import Partial.Unsafe (unsafePartial)
27+import Prelude as Prelude
28+import PureScript.Backend.Optimizer.CoreFn (Ann(..), Bind(..), Binder(..), Binding(..), CaseAlternative(..), CaseGuard(..), Comment(..), ConstructorType(..), Expr(..), Guard(..), Ident(..), Import(..), Literal(..), Meta(..), Module(..), ModuleName(..), Prop(..), ProperName(..), Qualified(..), ReExport(..), SourcePos, SourceSpan, emptySpan)
2229import Safe.Coerce (coerce)
30+import Unsafe.Coerce (unsafeCoerce)
2331
2432type JsonDecode = Either JsonDecodeError
2533
34+infixr 2 alt as <|>
35+
36+alt :: forall e a. Either e a -> (Unit -> Either e a) -> Either e a
37+alt a k = case a of
38+ Left _ -> k unit
39+ Right _ -> a
40+
41+-- Either's bind implementation is not ideal from an optimization
42+-- standpoint and generates awkward code.
43+bind :: forall e a b. Either e a -> (a -> Either e b) -> Either e b
44+bind a k = case a of
45+ Left err ->
46+ Left err
47+ Right a' ->
48+ k a'
49+
2650decodeSourcePos :: Json -> JsonDecode SourcePos
2751decodeSourcePos json = do
2852 Tuple line column <- decodeJson json
@@ -82,11 +106,12 @@ decodeMeta json = do
82106 throwError $ TypeMismatch "Meta"
83107
84108decodeAnn :: String -> Json -> JsonDecode Ann
85−decodeAnn path json = do
109+decodeAnn _path json = do
86110 obj <- decodeJObject json
87− span <- getField (decodeSourceSpan path) obj "sourceSpan"
111+ -- Currently disabled because spans are not used and are a performance drain.
112+ -- span <- getField (decodeSourceSpan path) obj "sourceSpan"
88113 meta <- getFieldOptional' decodeMeta obj "meta"
89− pure $ Ann { span, meta }
114+ pure $ Ann { span: emptySpan, meta }
90115
91116decodeImport :: forall a. (Json -> JsonDecode a) -> Json -> JsonDecode (Import a)
92117decodeImport decodeAnn' json = do
@@ -255,10 +280,107 @@ decodeLiteral dec json = do
255280 throwError $ TypeMismatch "Literal"
256281
257282decodeRecord :: forall a. (Json -> JsonDecode a) -> Json -> JsonDecode (Array (Prop a))
258−decodeRecord = decodeArray <<< map (map (uncurry Prop)) <<< decodeTuple decodeString
283+decodeRecord = decodeArray <<< decodeProp
284+ where
285+ decodeProp decoder json = do
286+ arr <- decodeJArray json
287+ case arr of
288+ [ a, b ] -> do
289+ prop <- decodeString a
290+ value <- decoder b
291+ pure $ Prop prop value
292+ _ ->
293+ Left $ TypeMismatch "Tuple"
259294
260295decodeComment :: Json -> JsonDecode Comment
261296decodeComment json = do
262297 obj <- decodeJObject json
263298 LineComment <$> getField decodeString obj "LineComment"
264− <|> BlockComment <$> getField decodeString obj "BlockComment"
299+ <|> \_ -> BlockComment <$> getField decodeString obj "BlockComment"
300+
301+decodeArray :: forall a. (Json -> JsonDecode a) -> Json -> JsonDecode (Array a)
302+decodeArray decoder json = case decodeJArray json of
303+ Left err ->
304+ Left err
305+ Right arr -> ST.run Prelude.do
306+ out <- STArray.new
307+ ix <- STRef.new 0
308+ con <- STRef.new true
309+ res <- STRef.new (unsafeCoerce unit)
310+ let len = Array.length arr
311+ ST.while (STRef.read con) Prelude.do
312+ ix' <- STRef.read ix
313+ if ix' == len then Prelude.do
314+ out' <- STArray.unsafeFreeze out
315+ _ <- STRef.write false con
316+ _ <- STRef.write (Right out') res
317+ pure unit
318+ else
319+ case decoder (unsafePartial (Array.unsafeIndex arr ix')) of
320+ Left err -> Prelude.do
321+ _ <- STRef.write false con
322+ _ <- STRef.write (Left (AtIndex ix' err)) res
323+ pure unit
324+ Right val -> Prelude.do
325+ _ <- STArray.push val out
326+ _ <- STRef.write (ix' + 1) ix
327+ pure unit
328+ STRef.read res
329+
330+getField :: forall a. (Json -> JsonDecode a) -> Object Json -> String -> JsonDecode a
331+getField decode obj prop =
332+ case Object.lookup prop obj of
333+ Nothing ->
334+ Left $ AtKey prop MissingValue
335+ Just json ->
336+ decode json
337+
338+getFieldOptional' :: forall a. (Json -> JsonDecode a) -> Object Json -> String -> JsonDecode (Maybe a)
339+getFieldOptional' decode obj prop = do
340+ case Object.lookup prop obj of
341+ Nothing ->
342+ Right Nothing
343+ Just json
344+ | isNull json ->
345+ Right Nothing
346+ | otherwise ->
347+ Just <$> decode json
348+
349+decodeJObject :: Json -> JsonDecode (Object Json)
350+decodeJObject = caseJson fail fail fail fail fail Right
351+ where
352+ fail :: forall a. a -> JsonDecode (Object Json)
353+ fail _ = Left $ TypeMismatch "Object"
354+
355+decodeJArray :: Json -> JsonDecode (Array Json)
356+decodeJArray = caseJson fail fail fail fail Right fail
357+ where
358+ fail :: forall a. a -> JsonDecode (Array Json)
359+ fail _ = Left $ TypeMismatch "Array"
360+
361+decodeString :: Json -> JsonDecode String
362+decodeString = caseJson fail fail fail Right fail fail
363+ where
364+ fail :: forall a. a -> JsonDecode String
365+ fail _ = Left $ TypeMismatch "String"
366+
367+decodeNumber :: Json -> JsonDecode Number
368+decodeNumber = caseJson fail fail Right fail fail fail
369+ where
370+ fail :: forall a. a -> JsonDecode Number
371+ fail _ = Left $ TypeMismatch "Number"
372+
373+decodeBoolean :: Json -> JsonDecode Boolean
374+decodeBoolean = caseJson fail Right fail fail fail fail
375+ where
376+ fail :: forall a. a -> JsonDecode Boolean
377+ fail _ = Left $ TypeMismatch "Boolean"
378+
379+decodeInt :: Json -> JsonDecode Int
380+decodeInt json = do
381+ num <- decodeNumber json
382+ case Int.fromNumber num of
383+ Nothing ->
384+ Left $ TypeMismatch "Int"
385+ Just int ->
386+ Right int