Fix JSON number literals

bril-sources/add.json

@@ -1,3 +1,4 @@
+{
 "functions": [
     {
       "instrs": [

eoc.cabal

@@ -24,7 +24,8 @@ library eoc-lib
         text >= 2.0,
         aeson >= 2.2,
         sorted-list ^>= 0.2,
-        bytestring >= 0.11
+        bytestring ^>= 0.11,
+        scientific ^>= 0.3
     default-language: Haskell2010
   default-extensions: DeriveGeneric, OverloadedStrings
 

lib/Bril.hs

@@ -5,7 +5,7 @@ module Bril (
     parseBrilFromPath, parseBrilJSON,
     )where
 
-import Data.Aeson (FromJSON, parseJSON, withObject, withText, (.:), (.:?), eitherDecode)
+import Data.Aeson (FromJSON, parseJSON, withObject, withText, withScientific, (.:), (.:?), eitherDecode)
 import Data.Aeson.Types (Parser, modifyFailure)
 import qualified Data.Aeson (Value, Object, Key)
 import Data.Aeson.KeyMap
@@ -14,6 +14,7 @@ import qualified Data.Text as T
 import Data.Text.Read (Reader, signed, decimal)
 import Data.SortedList
 import Data.Maybe (fromMaybe, isJust)
+import Data.Scientific (isInteger, toBoundedInteger)
 
 import qualified Data.ByteString.Lazy as LB
 
@@ -207,14 +208,24 @@ parseValue Bool =
              "true" -> return $ BoolValue True
              "false" -> return $ BoolValue False
              _ -> fail $ "invalid bool literal: " ++ (T.unpack v)
+--parseValue Int =
+--    withText "IntValue" $ \v ->
+--        case ((signed decimal :: Reader Int64) v) of
+--            Left x -> fail $ "invalid int literal: " ++ x
+--            Right (val, t) ->
+--                if (T.null t)
+--                    then return $ IntValue val
+--                    else fail $ "invalid int literal: " ++ (T.unpack v)
 parseValue Int =
-    withText "IntValue" $ \v ->
-        case ((signed decimal :: Reader Int64) v) of
-            Left x -> fail $ "invalid int literal: " ++ x
-            Right (val, t) ->
-                if (T.null t)
-                    then return $ IntValue val
-                    else fail $ "invalid int literal: " ++ (T.unpack v)
+    withScientific "IntValue" $ \v ->
+        if (not (isInteger v))
+            then fail $ "Invalid integer literal: " ++ (show v)
+            else do
+                let num = toBoundedInteger v :: Maybe Int64
+                case num of
+                    (Just n) -> return $ IntValue n
+                    _ -> fail $ "Integer exceeds int64: " ++ (show v)
+
           
 
 parseBrilJSON text = (eitherDecode text :: Either String Program)

tests/Main.hs

@@ -18,25 +18,22 @@ testTypes = TestCase $ do
 testLiterals :: Test
 testLiterals = TestCase $ do
     assertEqual "true literal"
-        (parseLiteral B.Bool "true") (Success $ B.BoolValue True)
+        (parseLiteral B.Bool ("true"::Text)) (Success $ B.BoolValue True)
     assertEqual "false literal"
-        (parseLiteral B.Bool "false") (Success $ B.BoolValue False)
+        (parseLiteral B.Bool ("false"::Text)) (Success $ B.BoolValue False)
     assertEqual "wrong bool literal"
-        (parseLiteral B.Bool "xxx") (Error "invalid bool literal: xxx")
+        (parseLiteral B.Bool ("xxx"::Text)) (Error "invalid bool literal: xxx")
 
     assertEqual "int literal"
-        (parseLiteral B.Int "1434") (Success $ B.IntValue 1434)
-    assertEqual "negative int literal"
-        (parseLiteral B.Int "-143443") (Success $ B.IntValue (- 143443))
+        (parseLiteral B.Int (1434 :: Int)) (Success $ B.IntValue 1434)
     assertEqual "wrong int literal"
-        (parseLiteral B.Int "123xz") (Error "invalid int literal: 123xz")
+        (parseLiteral B.Int (100000000000000000000 :: Integer))
+        (Error "Integer exceeds int64: 1.0e20")
     assertEqual "wrong int literal"
-        (parseLiteral B.Int "123.5") (Error "invalid int literal: 123.5")
-    assertEqual "wrong int literal"
-        (parseLiteral B.Int "123.5") (Error "invalid int literal: 123.5")
+        (parseLiteral B.Int (123.5 :: Double)) (Error "Invalid integer literal: 123.5")
 
     where
-        parseLiteral type_ x = (parse (B.parseValue type_) (toJSON (x::Text)))
+        parseLiteral type_ x = (parse (B.parseValue type_) (toJSON x))
 
 testInstrs :: Test
 testInstrs = TestCase $ do