parse arithmetic nan

src/Language/Wasm/Lexer.x

@@ -11,6 +11,7 @@ import qualified Data.Char as Char
 import qualified Data.ByteString.Lazy.UTF8 as LBSUtf8
 import Control.Applicative ((<$>))
 import Control.Monad (when)
+import Numeric.IEEE (infinity, nan, nanWithPayload)
 
 }
 
@@ -54,11 +55,9 @@ tokens :-
 <0> "nan"                                 { constToken $ TFloatLit nan }
 <0> "+nan"                                { constToken $ TFloatLit nan }
 <0> "-nan"                                { constToken $ TFloatLit minusNaN }
-<0> @nanhex                               { constToken $ TFloatLit nan {- TODO: real hex rep parsing -}}
+<0> $sign? @nanhex                        { parseNanSigned }
-<0> "+" @nanhex                           { constToken $ TFloatLit nan {- TODO: real hex rep parsing -}}
-<0> "-" @nanhex                           { constToken $ TFloatLit minusNaN {- TODO: real hex rep parsing -}}
 <0> "inf"                                 { constToken $ TFloatLit inf }
-<0> "+inf"                                 { constToken $ TFloatLit inf }
+<0> "+inf"                                { constToken $ TFloatLit inf }
 <0> "-inf"                                { constToken $ TFloatLit minusInf }
 <0> @keyword                              { tokenStr TKeyword }
 <0> @linecomment                          ;
@@ -99,11 +98,10 @@ isAllowedStringChar _userState (_pos, _rest, inp, _) _len _nextInp =
     let code = Char.ord char in
     code >= 0x20 && code /= 0x7f && char /= '"' && char /= '\\'
 
-minusNaN, nan, inf, minusInf :: Double
+minusNaN, inf, minusInf :: Double
-minusNaN = read "-NaN"
+minusNaN = -nan
-nan = read "NaN"
+inf = infinity
-inf = read "Infinity"
+minusInf = -infinity
-minusInf = read "-Infinity"
 
 parseSign :: (Num a) => LBS.ByteString -> ((a -> a), Int64)
 parseSign str =
@@ -122,6 +120,12 @@ parseHexalSignedInt = token $ \(pos, _, s, _) len ->
     let num = readHexFromPrefix (len - 2 - slen) $ LBSUtf8.drop (2 + slen) s in
     Lexeme pos $ TIntLit $ sign num
 
+parseNanSigned :: AlexAction Lexeme
+parseNanSigned = token $ \(pos, _, s, _) len -> 
+    let (sign, slen) = parseSign s in
+    let num = readHexFromPrefix (len - 6 - slen) $ LBSUtf8.drop (6 + slen) s in
+    Lexeme pos $ TFloatLit $ sign $ fromIntegral num
+
 parseDecimalSignedInt :: AlexAction Lexeme
 parseDecimalSignedInt = token $ \(pos, _, s, _) len ->
     let (sign, slen) = parseSign s in

src/Language/Wasm/Parser.y

@@ -71,6 +71,7 @@ import Control.Monad (guard)
 import Numeric.Natural (Natural)
 import Data.Word (Word32, Word64)
 import Data.Bits ((.|.))
+import Numeric.IEEE (infinity, nan)
 
 import Language.Wasm.Lexer (
         Token (
@@ -318,8 +319,7 @@ u32                   { Lexeme _ (TIntLit (asUInt32 -> Just $$)) }
 i32                   { Lexeme _ (TIntLit (asInt32 -> Just $$)) }
 i64                   { Lexeme _ (TIntLit (asInt64 -> Just $$)) }
 unrestricted_int      { Lexeme _ (TIntLit $$) }
-f32                   { Lexeme _ (TFloatLit (asFloat32 -> $$)) }
+f64                   { Lexeme _ (TFloatLit $$) }
-f64                   { Lexeme _ (TFloatLit (asFloat64 -> $$)) }
 offset                { Lexeme _ (TKeyword (asOffset -> Just $$)) }
 align                 { Lexeme _ (TKeyword (asAlign -> Just $$)) }
 string                { Lexeme _ (TStringLit (asString -> Just $$)) }
@@ -381,15 +381,14 @@ float32 :: { Float }
     | i32 { fromIntegral $1 }
     | i64 { fromIntegral $1 }
     | unrestricted_int { fromIntegral $1 }
-    | f32 { $1 }
+    | f64 { asFloat32 $1 }
 
 float64 :: { Double }
     : u32 { fromIntegral $1 }
     | i32 { fromIntegral $1 }
     | i64 { fromIntegral $1 }
     | unrestricted_int { fromIntegral $1 }
-    | f32 { realToFrac $1 }
+    | f64 { $1 }
-    | f64 { realToFrac $1 }
 
 plaininstr :: { PlainInstr }
     -- control instructions
@@ -801,9 +800,9 @@ function :: { [ModuleField] }
     : 'func' opt(ident) export_import_typeuse_locals_body { $3 $2 }
 
 export_import_typeuse_locals_body :: { Maybe Ident -> [ModuleField] }
-    : ')' { \i -> [MFFunc $ emptyFunction { ident = i }] }
+    : ')' { \i -> [MFFunc Nothing $ emptyFunction { ident = i }] }
     | raw_instr list(instruction) ')' {
-        \i -> [MFFunc $ emptyFunction { ident = i, body = $1 ++ concat $2 }]
+        \i -> [MFFunc Nothing $ emptyFunction { ident = i, body = $1 ++ concat $2 }]
     }
     | '(' export_import_typeuse_locals_body1 { $2 }
 
@@ -817,7 +816,7 @@ import_typeuse_locals_body1 :: { Maybe Ident -> ModuleField }
     : 'import' name name ')' typeuse ')' {
         \ident -> MFImport $ Import $2 $3 $ ImportFunc ident $5
     }
-    | typeuse_locals_body1 { MFFunc . $1 }
+    | typeuse_locals_body1 { MFFunc Nothing . $1 }
 
 typeuse_locals_body1 :: { Maybe Ident -> Function }
     : 'type' typeidx ')' signature_locals_body {
@@ -1100,10 +1099,7 @@ asInt64 val
     | otherwise = Nothing
 
 asFloat32 :: Double -> Float
-asFloat32 = realToFrac
+asFloat32 v = realToFrac v
-
-asFloat64 :: Double -> Double
-asFloat64 = id
 
 asOffset :: LBS.ByteString -> Maybe Natural
 asOffset str = do
@@ -1337,7 +1333,7 @@ data DataSegment = DataSegment {
 data ModuleField =
     MFType TypeDef
     | MFImport Import
-    | MFFunc Function
+    | MFFunc (Maybe Int) Function
     | MFTable Table
     | MFMem Memory
     | MFGlobal Global
@@ -1443,7 +1439,7 @@ desugarize fields =
         S.mems = map synMemoryToStruct $ mems mod,
         S.globals = map (synGlobalToStruct mod) $ globals mod,
         S.start = fmap (synStartToStruct mod) $ start mod,
-        S.exports = synExportsToStruct mod fields
+        S.exports = synExportsToStruct mod $ appendIndexToFuncs fields
     }
     where
         -- utils
@@ -1468,7 +1464,7 @@ desugarize fields =
         extractTypeDef defs (MFType _) = defs -- should be extracted before implicit defs
         extractTypeDef defs (MFImport Import { desc = ImportFunc _ typeUse }) =
             matchTypeUse defs typeUse
-        extractTypeDef defs (MFFunc Function { funcType, body }) =
+        extractTypeDef defs (MFFunc _ Function { funcType, body }) =
             extractTypeDefFromInstructions (matchTypeUse defs funcType) body
         extractTypeDef defs (MFGlobal Global { initializer }) =
             extractTypeDefFromInstructions defs initializer
@@ -1649,7 +1645,7 @@ desugarize fields =
             }
 
         extractFunction :: [Function] -> ModuleField -> [Function]
-        extractFunction funcs (MFFunc fun) = fun : funcs
+        extractFunction funcs (MFFunc _ fun) = fun : funcs
         extractFunction funcs _ = funcs
 
         getLabelIdx :: FunCtx -> LabelIndex -> Maybe Natural
@@ -1806,6 +1802,13 @@ desugarize fields =
         extractStart' start _ = start
 
         -- exports
+        appendIndexToFuncs :: [ModuleField] -> [ModuleField]
+        appendIndexToFuncs mf = reverse $ snd $ foldl' appendIndexToFunc (0, []) mf
+            where
+                appendIndexToFunc :: (Int, [ModuleField]) -> ModuleField -> (Int, [ModuleField])
+                appendIndexToFunc (idx, mf) (MFFunc _ fun) = (idx + 1, (MFFunc (Just idx) fun):mf)
+                appendIndexToFunc (idx, mf) f = (idx, f:mf)
+ 
         synExportsToStruct :: Module -> [ModuleField] -> [S.Export]
         synExportsToStruct mod (MFExport Export { name, desc = ExportFunc Nothing } : rest) =
             let
@@ -1819,7 +1822,7 @@ desugarize fields =
             let 
                 idx = fromIntegral $ case head rest' of
                     MFImport imp -> fromJust $ findIndex (== imp) funImports
-                    MFFunc fun -> length funImports + (fromJust $ findIndex (== fun) $ functions mod)
+                    MFFunc (Just idx) fun -> length funImports + idx
                     _ -> error "export statement without index has to be followed with import or function"
             in
             map (\name -> S.Export name $ S.ExportFunc idx) names ++ synExportsToStruct mod rest'

tests/Test.hs

@@ -34,7 +34,7 @@ compile file = do
 main :: IO ()
 main = do
   files <- Directory.listDirectory "tests/samples"
-  -- let files = ["imports.wast"]
+  -- let files = ["float_memory.wast"]
   scriptTestCases <- (`mapM` files) $ \file -> do
     content <- LBS.readFile $ "tests/samples/" ++ file
     let Right script = Parser.parseScript <$> Lexer.scanner content

wasm.cabal

@@ -31,6 +31,7 @@ library
     , utf8-string >=1.0
     , cereal >= 0.5
     , vector >= 0.12
+    , ieee754 >= 0.8
   build-tools:
       alex >=3.1.3
     , happy >=1.9.4