ref: 241e15cc1348f5c22a234330ca1042b0c07e591f
parent: 988bc524da79eac6954ad6ef45e578b7550d0387
author: Lennart Augustsson <lennart@augustsson.net>
date: Sat Nov 4 14:37:41 EDT 2023
Make floating point literals overloaded.
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
-v4.0
-1400
-((A :0 ((B (B (B (B C)))) ((B (B (B C))) ((B (B C)) P)))) ((A :1 (T (BK (BK (BK K))))) ((A :2 (T (K (BK (BK K))))) ((A :3 (T (K (K (BK K))))) ((A :4 (T (K (K (K K))))) ((A :5 (T (K (K (K A))))) ((A :6 (K (noDefault "Alternative.empty"))) ((A :7 (K (noDefault "Alternative.<|>"))) ((A :8 ((S (((S' S') ((B _14) _1)) (((C' _209) ((B _12) _1)) _392))) _5)) ((A :9 ((S (((S' C') _3) _4)) (((C' _13) _1) _391))) ((A :10 (((S' P) _2) (((C' _13) _1) _1157))) ((A :11 ((B (B (B (B C)))) ((B (B (B C))) ((B (B C)) P)))) ((A :12 (T (BK (BK (BK K))))) ((A :13 (T (K (BK (BK K))))) ((A :14 (T (K (K (BK K))))) ((A :15 (T (K (K (K K))))) ((A :16 (T (K (K (K A))))) ((A :17 (K (noDefault "Applicative.pure"))) ((A :18 (K (noDefault "Applicative.<*>"))) ((A :19 (((S' B) _14) (((C' _206) _12) _197))) ((A :20 (((S' B) _14) (((C' _209) _12) _198))) ((A :21 _1232) ((A :22 ((B _1273) _21)) ((A :23 (((S' _1273) _21) I)) ((A :24 _1202) ((A :25 (_24 "undefined")) ((A :26 I) ((A :27 (((C' B) _1231) ((C _196) _26))) ((A :28 (((C' _27) ((_205 _1243) _108)) ((_196 (_34 _1245)) _107))) ((A :29 ((B ((S _1273) (_34 _1245))) _24)) ((A :30 ((B (B (B C))) ((B (B C)) P))) ((A :31 (T (BK (BK K)))) ((A :32 (T (K (BK K)))) ((A :33 (T (K (K K)))) ((A :34 (T (K (K A)))) ((A :35 (K (noDefault "Monad.>>="))) ((A :36 (((C' (C' B)) _32) K)) ((A :37 ((B _13) _31)) ((A :38 (((S' (C' B)) _32) (((S' (C' B)) _32) (B' _34)))) ((A :39 P) ((A :40 (T K)) ((A :41 (T A)) ((A :42 (K _24)) ((A :43 ((B (B Y)) (((S' B) (B' ((B P) ((C _34) _391)))) (((S' (C' B)) ((B (B (C' B))) (B' _32))) (((S' (C' (C' B))) (B' _32)) (((C' B) (B' _34)) _392)))))) ((A :44 ((B (B Y)) (((S' B) (B' ((B P) ((C _34) _1157)))) (((C' (C' B)) ((B (B (C' B))) (B' _32))) BK)))) ((A :45 ((B T) ((C _34) _1157))) ((A :46 ((C _43) _197)) ((A :47 ((B _199) _32)) ((A :48 ((B C) ((B C') _32))) ((A :49 ((B _199) _48)) ((A :50 T) ((A :51 ((_204 ((B (B (_194 _50))) ((B ((C' C) _54)) (B P)))) (_208 _51))) ((A :52 (((((_11 _51) ((B (_194 _50)) P)) (_38 _53)) ((B (B (_194 _50))) (((C' B) ((B C) _54)) (BK _54)))) (_20 _52))) ((A :53 ((((_30 _52) ((B (B (_194 _50))) (((C' B) ((B C) _54)) (B _54)))) (_15 _52)) (_13 _52))) ((A :54 (T I)) ((A :55 ((B (_196 _463)) _54)) ((A :56 ((B (_194 _50)) (B (P _1157)))) ((A :57 ((B (_194 _50)) (BK (P _1157)))) ((A :58 ((_194 _50) ((S P) I))) ((A :59 ((B (_194 _50)) ((C (S' P)) I))) ((A :60 ((_134 ((C ((C S') _65)) I)) (_138 _60))) ((A :61 (((_1371 (K ((P (_1380 "False")) (_1380 "True")))) (_1376 _61)) (_1377 _61))) ((A :62 ((_69 _67) _68)) ((A :63 (R _68)) ((A :64 (T _67)) ((A :65 ((P _68) _67)) ((A :66 _68) ((A :67 K) ((A :68 A) ((A :69 P) ((A :70 (T K)) ((A :71 (T A)) ((A :72 (K (noDefault "Bounded.minBound"))) ((A :73 (K (noDefault "Bounded.maxBound"))) ((A :74 ((_134 _1196) _1197)) ((A :75 ((((((((_424 _74) (_433 _75)) _1198) _1199) _1200) _1201) (_438 _75)) (_439 _75))) ((A :76 ((_134 _1206) (_138 _76))) ((A :77 ((((((((_424 _76) _1205) (((C' (C' (_135 _440))) _1205) _444)) (((C' (C' (_136 _440))) _1205) _446)) (((C' (C' (_135 _440))) _1205) _446)) (((C' (C' (_136 _440))) _1205) _446)) (_438 _77)) (_439 _77))) ((A :78 ((_69 (_79 #0)) (_79 #127))) ((A :79 _1207) ((A :80 _1208) ((A :81 (((S' _64) (_1199 #97)) ((C _1199) #122))) ((A :82 (((S' _64) (_1199 #65)) ((C _1199) #90))) ((A :83 (((S' _63) _81) _82)) ((A :84 (((S' _64) (_1199 #48)) ((C _1199) #57))) ((A :85 (((S' _63) _83) _84)) ((A :86 (((S' _64) (_1199 #32)) ((C _1199) #126))) ((A :87 (((S' _63) ((C (_135 _74)) #32)) (((S' _63) ((C (_135 _74)) #9)) ((C (_135 _74)) #10)))) ((A :88 ((S ((S (((S' _64) (_1199 #65)) ((C _1199) #90))) (_68 (((noMatch "lib/Data/Char.hs") #72) #9)))) ((B _79) (((C' (_409 _210)) (((C' (_410 _210)) _80) (_80 #65))) (_80 #97))))) ((A :89 ((S ((S (((S' _64) (_1199 #97)) ((C _1199) #97))) (_68 (((noMatch "lib/Data/Char.hs") #76) #9)))) ((B _79) (((C' (_409 _210)) (((C' (_410 _210)) _80) (_80 #97))) (_80 #65))))) ((A :90 (((_1371 (K ((C ((S ((C ==) #39)) ((B (_196 (_1379 #39))) (((C' _196) ((B _1380) _91)) (_1379 #39))))) (_1380 "'\92&''")))) (_1376 _90)) ((B (_196 (_1379 #34))) (Y ((B (P (_1379 #34))) (((S' C) ((
\ No newline at end of file
+v4.1
+1404
+((A :0 ((B (B (B (B C)))) ((B (B (B C))) ((B (B C)) P)))) ((A :1 (T (BK (BK (BK K))))) ((A :2 (T (K (BK (BK K))))) ((A :3 (T (K (K (BK K))))) ((A :4 (T (K (K (K K))))) ((A :5 (T (K (K (K A))))) ((A :6 (K (noDefault "Alternative.empty"))) ((A :7 (K (noDefault "Alternative.<|>"))) ((A :8 ((S (((S' S') ((B _14) _1)) (((C' _210) ((B _12) _1)) _393))) _5)) ((A :9 ((S (((S' C') _3) _4)) (((C' _13) _1) _392))) ((A :10 (((S' P) _2) (((C' _13) _1) _1161))) ((A :11 ((B (B (B (B C)))) ((B (B (B C))) ((B (B C)) P)))) ((A :12 (T (BK (BK (BK K))))) ((A :13 (T (K (BK (BK K))))) ((A :14 (T (K (K (BK K))))) ((A :15 (T (K (K (K K))))) ((A :16 (T (K (K (K A))))) ((A :17 (K (noDefault "Applicative.pure"))) ((A :18 (K (noDefault "Applicative.<*>"))) ((A :19 (((S' B) _14) (((C' _207) _12) _198))) ((A :20 (((S' B) _14) (((C' _210) _12) _199))) ((A :21 _1236) ((A :22 ((B _1277) _21)) ((A :23 (((S' _1277) _21) I)) ((A :24 _1206) ((A :25 (_24 "undefined")) ((A :26 I) ((A :27 (((C' B) _1235) ((C _197) _26))) ((A :28 (((C' _27) ((_206 _1247) _109)) ((_197 (_34 _1249)) _108))) ((A :29 ((B ((S _1277) (_34 _1249))) _24)) ((A :30 ((B (B (B C))) ((B (B C)) P))) ((A :31 (T (BK (BK K)))) ((A :32 (T (K (BK K)))) ((A :33 (T (K (K K)))) ((A :34 (T (K (K A)))) ((A :35 (K (noDefault "Monad.>>="))) ((A :36 (((C' (C' B)) _32) K)) ((A :37 ((B _13) _31)) ((A :38 (((S' (C' B)) _32) (((S' (C' B)) _32) (B' _34)))) ((A :39 P) ((A :40 (T K)) ((A :41 (T A)) ((A :42 (K _24)) ((A :43 ((B (B Y)) (((S' B) (B' ((B P) ((C _34) _392)))) (((S' (C' B)) ((B (B (C' B))) (B' _32))) (((S' (C' (C' B))) (B' _32)) (((C' B) (B' _34)) _393)))))) ((A :44 ((B (B Y)) (((S' B) (B' ((B P) ((C _34) _1161)))) (((C' (C' B)) ((B (B (C' B))) (B' _32))) BK)))) ((A :45 ((B T) ((C _34) _1161))) ((A :46 ((C _43) _198)) ((A :47 ((B _200) _32)) ((A :48 ((B C) ((B C') _32))) ((A :49 ((B _200) _48)) ((A :50 T) ((A :51 ((_205 ((B (B (_195 _50))) ((B ((C' C) _54)) (B P)))) (_209 _51))) ((A :52 (((((_11 _51) ((B (_195 _50)) P)) (_38 _53)) ((B (B (_195 _50))) (((C' B) ((B C) _54)) (BK _54)))) (_20 _52))) ((A :53 ((((_30 _52) ((B (B (_195 _50))) (((C' B) ((B C) _54)) (B _54)))) (_15 _52)) (_13 _52))) ((A :54 (T I)) ((A :55 ((B (_197 _465)) _54)) ((A :56 ((B (_195 _50)) (B (P _1161)))) ((A :57 ((B (_195 _50)) (BK (P _1161)))) ((A :58 ((_195 _50) ((S P) I))) ((A :59 ((B (_195 _50)) ((C (S' P)) I))) ((A :60 ((_135 ((C ((C S') _65)) I)) (_139 _60))) ((A :61 (((_1375 (K ((P (_1384 "False")) (_1384 "True")))) (_1380 _61)) (_1381 _61))) ((A :62 ((_69 _67) _68)) ((A :63 (R _68)) ((A :64 (T _67)) ((A :65 ((P _68) _67)) ((A :66 _68) ((A :67 K) ((A :68 A) ((A :69 P) ((A :70 (T K)) ((A :71 (T A)) ((A :72 (K (noDefault "Bounded.minBound"))) ((A :73 (K (noDefault "Bounded.maxBound"))) ((A :74 ((_135 _1200) _1201)) ((A :75 ((((((((_425 _74) (_434 _75)) _1202) _1203) _1204) _1205) (_439 _75)) (_440 _75))) ((A :76 ((_135 _1210) (_139 _76))) ((A :77 ((((((((_425 _76) _1209) (((C' (C' (_136 _441))) _1209) _445)) (((C' (C' (_137 _441))) _1209) _447)) (((C' (C' (_136 _441))) _1209) _447)) (((C' (C' (_137 _441))) _1209) _447)) (_439 _77)) (_440 _77))) ((A :78 ((_69 (_79 #0)) (_79 #127))) ((A :79 _1211) ((A :80 _1212) ((A :81 (((S' _64) (_1203 #97)) ((C _1203) #122))) ((A :82 (((S' _64) (_1203 #65)) ((C _1203) #90))) ((A :83 (((S' _63) _81) _82)) ((A :84 (((S' _64) (_1203 #48)) ((C _1203) #57))) ((A :85 (((S' _63) _83) _84)) ((A :86 (((S' _64) (_1203 #32)) ((C _1203) #126))) ((A :87 (((S' _63) ((C (_136 _74)) #32)) (((S' _63) ((C (_136 _74)) #9)) ((C (_136 _74)) #10)))) ((A :88 ((S ((S (((S' _64) (_1203 #65)) ((C _1203) #90))) (_68 (((noMatch "lib/Data/Char.hs") #72) #9)))) ((B _79) (((C' (_410 _211)) (((C' (_411 _211)) _80) (_80 #65))) (_80 #97))))) ((A :89 ((S ((S (((S' _64) (_1203 #97)) ((C _1203) #97))) (_68 (((noMatch "lib/Data/Char.hs") #76) #9)))) ((B _79) (((C' (_410 _211)) (((C' (_411 _211)) _80) (_80 #97))) (_80 #65))))) ((A :90 (((_1375 (K ((C ((S ((C ==) #39)) ((B (_197 (_1383 #39))) (((C' _197) ((B _1384) _91)) (_1383 #39))))) (_1384 "'\92&''")))) (_1380 _90)) ((B (_197 (_1383 #34))) (Y ((B (P (_1383 #34))) (((S' C) ((
\ No newline at end of file
--- a/lib/Data/Double.hs
+++ b/lib/Data/Double.hs
@@ -10,6 +10,7 @@
import Data.Integer
import Data.Ord
import Data.Ratio
+import Data.Real
import Data.Num
import Text.Show
@@ -47,6 +48,9 @@
-- herculean task of its own...
instance Show Double where
show = primDoubleShow
+
+instance Real Double where
+ toRational _ = error "Double.toRational not implemented"
instance Floating Double where
pi = 3.141592653589793
--- a/lib/Data/Ratio.hs
+++ b/lib/Data/Ratio.hs
@@ -50,7 +50,7 @@
| y == 0 = error "Data.Ratio.recip: division by 0"
| x < 0 = negate y :% negate x
| otherwise = y :% x
--- fromRational (x:%y) = fromInteger x % fromInteger y
+ fromRational (x:%y) = fromInteger x % fromInteger y
instance forall a . (Show a) => Show (Ratio a) where
showsPrec p (x:%y) = showParen (p > 7) $
--- a/lib/Data/Ratio_Type.hs
+++ b/lib/Data/Ratio_Type.hs
@@ -8,3 +8,6 @@
_integerToRational :: Integer -> Rational
_integerToRational x = x :% (1::Integer)
+
+_mkRational :: Integer -> Integer -> Rational
+_mkRational = (:%)
--- a/lib/Prelude.hs
+++ b/lib/Prelude.hs
@@ -22,6 +22,7 @@
module Data.Maybe,
module Data.Num,
module Data.Ord,
+ module Data.Ratio,
module Data.Real,
module Data.Tuple,
module System.IO,
@@ -51,6 +52,7 @@
import Data.Maybe
import Data.Num
import Data.Ord
+import Data.Ratio(Rational)
import Data.Real
import Data.Tuple
import System.IO
--- a/src/Compat.hs
+++ b/src/Compat.hs
@@ -4,6 +4,7 @@
module Compat(module Compat) where
--import Control.Exception
import qualified Data.Function as F
+import Data.Char
import Data.Time
import Data.Time.Clock.POSIX
--import qualified Control.Monad as M
@@ -183,3 +184,28 @@
anySameBy :: (a -> a -> Bool) -> [a] -> Bool
anySameBy _ [] = False
anySameBy eq (x:xs) = elemBy eq x xs || anySameBy eq xs
+
+-- Convert string in scientific notation to a rational number.
+readRational :: String -> Rational
+readRational "" = undefined
+readRational acs@(sgn:as) | sgn == '-' = negate $ rat1 as
+ | otherwise = rat1 acs
+ where
+ rat1 s1 =
+ case span isDigit s1 of
+ (ds1, cr1) | ('.':r1) <- cr1 -> rat2 f1 r1+ | (c:r1) <- cr1, toLower c == 'e' -> rat3 f1 r1
+ | otherwise -> f1
+ where f1 = toRational (readInteger ds1)
+
+ rat2 f1 s2 =
+ case span isDigit s2 of
+ (ds2, cr2) | (c:r2) <- cr2, toLower c == 'e' -> rat3 f2 r2
+ | otherwise -> f2
+ where f2 = f1 + toRational (readInteger ds2) * 10 ^^ (negate $ length ds2)
+
+ rat3 f2 ('+':s) = f2 * expo s+ rat3 f2 ('-':s) = f2 / expo s+ rat3 f2 s = f2 * expo s
+
+ expo s = 10 ^ readInteger s
--- a/src/MicroHs/Desugar.hs
+++ b/src/MicroHs/Desugar.hs
@@ -10,6 +10,7 @@
import Data.Char
import Data.List
import Data.Maybe
+import Data.Ratio
import Control.Monad.State.Strict as S --Xhiding(ap)
--Ximport Control.Monad as S hiding(ap)
--Ximport Compat
@@ -172,7 +173,7 @@
bnds body
encodeInteger :: Integer -> Exp
-encodeInteger i | -1000 < i && i < 1000 = -- XXX use better bounds
+encodeInteger i | toInteger (minBound::Int) <= i && i < toInteger (maxBound::Int) =
-- trace ("*** small integer " ++ show i) $App (Var (mkIdent "Data.Integer_Type._intToInteger")) (Lit (LInt (_integerToInt i)))
| otherwise =
@@ -179,6 +180,10 @@
-- trace ("*** large integer " ++ show i) $App (Var (mkIdent "Data.Integer._intListToInteger")) (encodeList (map (Lit . LInt) (_integerToIntList i)))
+encodeRational :: Rational -> Exp
+encodeRational r =
+ App (App (Var (mkIdent "Data.Ratio_Type._mkRational")) (encodeInteger (numerator r))) (encodeInteger (denominator r))
+
dsExpr :: Expr -> Exp
dsExpr aexpr =
case aexpr of
@@ -187,6 +192,7 @@
ELam qs -> dsEqns (getSLocExpr aexpr) qs
ELit _ (LChar c) -> Lit (LInt (ord c))
ELit _ (LInteger i) -> encodeInteger i
+ ELit _ (LRat i) -> encodeRational i
ELit _ l -> Lit l
ECase e as -> dsCase (getSLocExpr aexpr) e as
ELet ads e -> dsBinds ads (dsExpr e)
--- a/src/MicroHs/Exp.hs
+++ b/src/MicroHs/Exp.hs
@@ -140,6 +140,7 @@
else
toStringP (encodeString s)
Lit (LInteger _) -> undefined
+ Lit (LRat _) -> undefined
Lit l -> (showLit l ++)
Lam x e -> (("(\\" ++ showIdent x ++ " ") ++) . toStringP e . (")" ++) App f a -> ("(" ++) . toStringP f . (" " ++) . toStringP a . (")" ++)--- a/src/MicroHs/Expr.hs
+++ b/src/MicroHs/Expr.hs
@@ -146,19 +146,23 @@
= LInt Int
| LInteger Integer
| LDouble Double
+ | LRat Rational
| LChar Char
| LStr String
| LPrim String
| LForImp String
--Xderiving (Show)
---Winstance NFData Lit where rnf (LInt i) = rnf i; rnf (LInteger i) = rnf i; rnf (LDouble d) = rnf d; rnf (LChar c) = rnf c; rnf (LStr s) = rnf s; rnf (LPrim s) = rnf s; rnf (LForImp s) = rnf s
+--Winstance NFData Lit where rnf (LInt i) = rnf i; rnf (LInteger i) = rnf i; rnf (LDouble d) = rnf d; rnf (LRat r) = rnf r; rnf (LChar c) = rnf c; rnf (LStr s) = rnf s; rnf (LPrim s) = rnf s; rnf (LForImp s) = rnf s
instance Eq Lit where
- (==) (LInt x) (LInt y) = x == y
- (==) (LChar x) (LChar y) = x == y
- (==) (LStr x) (LStr y) = x == y
- (==) (LPrim x) (LPrim y) = x == y
- (==) (LForImp x) (LForImp y) = x == y
+ (==) (LInt x) (LInt y) = x == y
+ (==) (LInteger x) (LInteger y) = x == y
+ (==) (LDouble x) (LDouble y) = x == y
+ (==) (LRat x) (LRat y) = x == y
+ (==) (LChar x) (LChar y) = x == y
+ (==) (LStr x) (LStr y) = x == y
+ (==) (LPrim x) (LPrim y) = x == y
+ (==) (LForImp x) (LForImp y) = x == y
(==) _ _ = False
type ECaseArm = (EPat, EAlts)
@@ -523,7 +527,8 @@
case l of
LInt i -> '#' : show i
LInteger i -> '#' : '#' : show i
- LDouble d -> '%' : show d
+ LDouble d -> '&' : show d
+ LRat r -> '%' : show r
LChar c -> xshowChar c
LStr s -> show s
LPrim s -> s
--- a/src/MicroHs/Lex.hs
+++ b/src/MicroHs/Lex.hs
@@ -13,7 +13,7 @@
| TString Loc String
| TChar Loc Char
| TInt Loc Integer
- | TDouble Loc Double
+ | TRat Loc Rational
| TSpec Loc Char
| TError Loc String
| TBrace Loc
@@ -25,7 +25,7 @@
showToken (TString _ s) = show s
showToken (TChar _ c) = show c
showToken (TInt _ i) = show i
-showToken (TDouble _ d) = show d
+showToken (TRat _ d) = show d
showToken (TSpec _ c) = [c]
showToken (TError _ s) = "ERROR " ++ s
showToken (TBrace _) = "TBrace"
@@ -115,7 +115,7 @@
case span isDigit (tail rs) of
(ns, rs') ->
let s = sign ++ ds ++ '.':ns
- mkD x r = TDouble loc (readDouble x) : lex (addCol loc $ length x) r
+ mkD x r = TRat loc (readRational x) : lex (addCol loc $ length x) r
in case expo rs' of
Nothing -> mkD s rs'
Just (es, rs'') -> mkD (s ++ es) rs''
@@ -201,7 +201,7 @@
tokensLoc (TString loc _ :_) = loc
tokensLoc (TChar loc _ :_) = loc
tokensLoc (TInt loc _ :_) = loc
-tokensLoc (TDouble loc _ : _) = loc
+tokensLoc (TRat loc _ : _) = loc
tokensLoc (TSpec loc _ :_) = loc
tokensLoc (TError loc _ :_) = loc
tokensLoc (TBrace loc :_) = loc
--- a/src/MicroHs/Main.hs
+++ b/src/MicroHs/Main.hs
@@ -71,4 +71,4 @@
putStrLn $ "final pass " ++ padLeft 6 (show (t2-t1)) ++ "ms"
version :: String
-version = "v4.0\n"
+version = "v4.1\n"
--- a/src/MicroHs/Parse.hs
+++ b/src/MicroHs/Parse.hs
@@ -216,7 +216,7 @@
is (TString (l, c) s) = Just (ELit (SLoc fn l c) (LStr s))
is (TChar (l, c) a) = Just (ELit (SLoc fn l c) (LChar a))
is (TInt (l, c) i) = Just (ELit (SLoc fn l c) (LInteger i))
- is (TDouble (l, c) d) = Just (ELit (SLoc fn l c) (LDouble d))
+ is (TRat (l, c) d) = Just (ELit (SLoc fn l c) (LRat d))
is _ = Nothing
satisfyM "literal" is
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -1422,15 +1422,15 @@
case l of
LInteger i -> tcLit mt loc' (LInt (_integerToInt i))
_ -> tcLit mt loc' l
- _ ->
+ _ -> do
+ let getExpected (Infer _) = pure Nothing
+ getExpected (Check t) = do
+ t' <- derefUVar t >>= expandSyn
+ case t' of
+ EVar v -> pure (Just v)
+ _ -> pure Nothing
case l of
LInteger i -> do
- let getExpected (Infer _) = pure Nothing
- getExpected (Check t) = do
- t' <- derefUVar t >>= expandSyn
- case t' of
- EVar v -> pure (Just v)
- _ -> pure Nothing
mex <- getExpected mt
case mex of
-- Convert to Int in the compiler, that way (99::Int) will never involve fromInteger
@@ -1444,7 +1444,16 @@
(_at, rt) <- unArrow loc ft
-- We don't need to check that _at is Integer, it's part of the fromInteger type.
instSigma loc (EApp f ae) rt mt
- -- Not LInteger
+ LRat r -> do
+ mex <- getExpected mt
+ case mex of
+ Just v | v == mkIdent nameDouble -> tcLit mt loc' (LDouble (fromRational r))
+ _ -> do
+ (f, ft) <- tInferExpr (EVar (mkIdentSLoc loc' "fromRational")) -- XXX should have this qualified somehow
+ (_at, rt) <- unArrow loc ft
+ -- We don't need to check that _at is Rational, it's part of the fromRational type.
+ instSigma loc (EApp f ae) rt mt
+ -- Not LInteger, LRat
_ -> tcLit mt loc' l
ECase a arms -> do
(ea, ta) <- tInferExpr a
--- a/src/runtime/eval.c
+++ b/src/runtime/eval.c
@@ -136,7 +136,7 @@
/***************************************/
-#define VERSION "v4.0\n"
+#define VERSION "v4.1\n"
/* Keep permanent nodes for LOW_INT <= i < HIGH_INT */
#define LOW_INT (-10)
@@ -1093,7 +1093,7 @@
ARG(r) = parse(f);
if (!gobble(f, ')')) ERR("parse ')'");return r;
- case '%':
+ case '&':
d = parse_double(f);
r = mkDouble(d);
return r;
--- a/tests/FArith.hs
+++ b/tests/FArith.hs
@@ -1,14 +1,13 @@
module FArith(module FArith) where
import Prelude
-import Data.Double
import Text.String
list1 :: [Double]
-list1 = [-100.343241, -53.3248973, -0.0, 0.0, 1.0, 1.23453523, 3243534.34534, 999.999]
+list1 = [-100.343241, -53.3248973, 0.0, 1.0, 1.23453523, 3243534.34534, 999.999]
list2 :: [Double]
-list2 = [-100.343241, -53.3248973, -0.0, 0.0, 1.0, 1.23453523, 3243534.34534, 999.999]
+list2 = [-100.343241, -53.3248973, 0.0, 1.0, 1.23453523, 3243534.34534, 999.999, 1.2e33]
divide :: Double -> Double -> Double
divide x y = if y == 0.0 then 0.0 else x / y
@@ -17,8 +16,8 @@
main = do
putStrLn $ show [ op x y | x <- list1, y <- list2, op <- [(+), (-), (*), divide] ]
putStrLn $ show [ op x y | x <- list1, y <- list2, op <- [(==), (/=), (<), (<=), (>), (>=)] ]
- putStrLn $ show [ x / y | x <- [2.234983, 1.232, 23.0], y <- [1.0, 5.0, 10.0, 100.0]]
- putStrLn $ show [ x / y | x <- [-2.234983, -1.232, -23.0], y <- [1.0, -5.0, 10.0, -100.0]]
+ putStrLn $ show [ x / y | x <- [2.234983, 1.232, 23.0::Double], y <- [1.0, 5.0, 10.0, 100.0]]
+ putStrLn $ show [ x / y | x <- [-2.234983, -1.232, -23.0::Double], y <- [1.0, -5.0, 10.0, -100.0]]
let str = readDouble "1.576"
putStrLn $ show str
putStrLn $ show $ 1.0 + readDouble "2.5"
--- a/tests/FArith.ref
+++ b/tests/FArith.ref
@@ -1,5 +1,5 @@
-[-200.686482,0.0,10068.76601438408,1.0,-153.6681383,-47.0183437,5350.79302107415,1.881733413108702,-100.343241,-100.343241,0.0,0.0,-100.343241,-100.343241,-0.0,0.0,-99.34324100000001,-101.343241,-100.343241,-100.343241,-99.10870577,-101.57777623,-123.8772661068804,-81.28017618419848,3243434.002099,-3243634.688581,-325466748.5062289,-3.093638923360364e-05,899.655759,-1100.342241,-100343.140656759,-0.1003433413433413,-153.6681383,47.0183437,5350.79302107415,0.53142490484237,-106.6497946,0.0,2843.544672055548,1.0,-53.3248973,-53.3248973,0.0,0.0,-53.3248973,-53.3248973,-0.0,0.0,-52.3248973,-54.3248973,-53.3248973,-53.3248973,-52.09036207,-54.55943253,-65.83146435298188,-43.19430989425875,3243481.0204427,-3243587.6702373,-172961135.8542782,-1.644036770463433e-05,946.6741027,-1053.3238973,-53324.8439751027,-0.05332495062495063,-100.343241,100.343241,0.0,0.0,-53.3248973,53.3248973,0.0,0.0,-0.0,0.0,0.0,0.0,0.0,-0.0,-0.0,0.0,1.0,-1.0,-0.0,-0.0,1.23453523,-1.23453523,-0.0,-0.0,3243534.34534,-3243534.34534,-0.0,-0.0,999.999,-999.999,-0.0,-0.0,-100.343241,100.343241,-0.0,-0.0,-53.3248973,53.3248973,-0.0,-0.0,0.0,0.0,-0.0,0.0,0.0,0.0,0.0,0.0,1.0,-1.0,0.0,0.0,1.23453523,-1.23453523,0.0,0.0,3243534.34534,-3243534.34534,0.0,0.0,999.999,-999.999,0.0,0.0,-99.34324100000001,101.343241,-100.343241,-0.009965793311380085,-52.3248973,54.3248973,-53.3248973,-0.01875296626215912,1.0,1.0,-0.0,0.0,1.0,1.0,0.0,0.0,2.0,0.0,1.0,1.0,2.23453523,-0.2345352300000001,1.23453523,0.8100214361642801,3243535.34534,-3243533.34534,3243534.34534,3.083056609024981e-07,1000.999,-998.999,999.999,0.001000001000001,-99.10870577,101.57777623,-123.8772661068804,-0.01230312293779708,-52.09036207,54.55943253,-65.83146435298188,-0.02315119751763685,1.23453523,1.23453523,-0.0,0.0,1.23453523,1.23453523,0.0,0.0,2.23453523,0.2345352300000001,1.23453523,1.23453523,2.46907046,0.0,1.524077234111153,1.0,3243535.57987523,-3243533.11080477,4004257.419037217,3.806141999925675e-07,1001.23353523,-998.76446477,1234.53399546477,0.001234536464536465,3243434.002099,3243634.688581,-325466748.5062289,-32324.39288402096,3243481.0204427,3243587.6702373,-172961135.8542782,-60825.89014831539,3243534.34534,3243534.34534,-0.0,0.0,3243534.34534,3243534.34534,0.0,0.0,3243535.34534,3243533.34534,3243534.34534,3243534.34534,3243535.57987523,3243533.11080477,4004257.419037217,2627332.348660475,6487068.69068,0.0,10520515049400.18,1.0,3244534.34434,3242534.34634,3243531101.805655,3243.537588877589,899.655759,1100.342241,-100343.140656759,-9.965783345586773,946.6741027,1053.3238973,-53324.8439751027,-18.75294750919286,999.999,999.999,-0.0,0.0,999.999,999.999,0.0,0.0,1000.999,998.999,999.999,999.999,1001.23353523,998.76446477,1234.53399546477,810.020626142844,3244534.34434,-3242534.34634,3243531101.805655,0.0003083053525968371,1999.998,0.0,999998.000001,1.0]
-[True,False,False,True,False,True,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,False,False,True,True,True,False,False,True,False,True,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,False,False,True,True,False,True,False,False,True,True,True,False,False,True,False,True,True,False,False,True,False,True,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,False,False,True,True,False,True,False,False,True,True,True,False,False,True,False,True,True,False,False,True,False,True,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,True,False,False,True,False,True,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,True,False,False,True,False,True,False,True,True,True,False,False,False,True,True,True,False,False,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,True,False,False,True,False,True,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,False,True,True,True,False,False,True,False,False,True,False,True]
+[-200.686482,0.0,10068.76601438408,1.0,-153.6681383,-47.0183437,5350.79302107415,1.881733413108702,-100.343241,-100.343241,-0.0,0.0,-99.34324100000001,-101.343241,-100.343241,-100.343241,-99.10870577,-101.57777623,-123.8772661068804,-81.28017618419848,3243434.002099,-3243634.688581,-325466748.5062289,-3.093638923360364e-05,899.655759,-1100.342241,-100343.140656759,-0.1003433413433413,1.2e+33,-1.2e+33,-1.204118892e+35,-8.36193675e-32,-153.6681383,47.0183437,5350.79302107415,0.53142490484237,-106.6497946,0.0,2843.544672055548,1.0,-53.3248973,-53.3248973,-0.0,0.0,-52.3248973,-54.3248973,-53.3248973,-53.3248973,-52.09036207,-54.55943253,-65.83146435298188,-43.19430989425875,3243481.0204427,-3243587.6702373,-172961135.8542782,-1.644036770463433e-05,946.6741027,-1053.3238973,-53324.8439751027,-0.05332495062495063,1.2e+33,-1.2e+33,-6.398987676000001e+34,-4.443741441666667e-32,-100.343241,100.343241,-0.0,-0.0,-53.3248973,53.3248973,-0.0,-0.0,0.0,0.0,0.0,0.0,1.0,-1.0,0.0,0.0,1.23453523,-1.23453523,0.0,0.0,3243534.34534,-3243534.34534,0.0,0.0,999.999,-999.999,0.0,0.0,1.2e+33,-1.2e+33,0.0,0.0,-99.34324100000001,101.343241,-100.343241,-0.009965793311380085,-52.3248973,54.3248973,-53.3248973,-0.01875296626215912,1.0,1.0,0.0,0.0,2.0,0.0,1.0,1.0,2.23453523,-0.2345352300000001,1.23453523,0.8100214361642801,3243535.34534,-3243533.34534,3243534.34534,3.083056609024981e-07,1000.999,-998.999,999.999,0.001000001000001,1.2e+33,-1.2e+33,1.2e+33,8.333333333333333e-34,-99.10870577,101.57777623,-123.8772661068804,-0.01230312293779708,-52.09036207,54.55943253,-65.83146435298188,-0.02315119751763685,1.23453523,1.23453523,0.0,0.0,2.23453523,0.2345352300000001,1.23453523,1.23453523,2.46907046,0.0,1.524077234111153,1.0,3243535.57987523,-3243533.11080477,4004257.419037217,3.806141999925675e-07,1001.23353523,-998.76446477,1234.53399546477,0.001234536464536465,1.2e+33,-1.2e+33,1.481442276e+33,1.028779358333333e-33,3243434.002099,3243634.688581,-325466748.5062289,-32324.39288402096,3243481.0204427,3243587.6702373,-172961135.8542782,-60825.89014831539,3243534.34534,3243534.34534,0.0,0.0,3243535.34534,3243533.34534,3243534.34534,3243534.34534,3243535.57987523,3243533.11080477,4004257.419037217,2627332.348660475,6487068.69068,0.0,10520515049400.18,1.0,3244534.34434,3242534.34634,3243531101.805655,3243.537588877589,1.2e+33,-1.2e+33,3.892241214408e+39,2.702945287783333e-27,899.655759,1100.342241,-100343.140656759,-9.965783345586773,946.6741027,1053.3238973,-53324.8439751027,-18.75294750919286,999.999,999.999,0.0,0.0,1000.999,998.999,999.999,999.999,1001.23353523,998.76446477,1234.53399546477,810.020626142844,3244534.34434,-3242534.34634,3243531101.805655,0.0003083053525968371,1999.998,0.0,999998.000001,1.0,1.2e+33,-1.2e+33,1.1999988e+36,8.333325e-31]
+[True,False,False,True,False,True,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,False,False,True,True,True,False,False,True,False,True,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,False,False,True,True,False,True,False,False,True,True,True,False,False,True,False,True,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,True,False,False,True,False,True,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,True,False,False,True,False,True,False,True,True,True,False,False,False,True,True,True,False,False,False,True,True,True,False,False,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,True,False,False,True,False,True,False,True,False,False,True,True,False,True,True,True,False,False,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,False,True,False,False,True,True,False,True,True,True,False,False,True,False,False,True,False,True,False,True,True,True,False,False]
[2.234983,0.4469966,0.2234983,0.02234983,1.232,0.2464,0.1232,0.01232,23.0,4.6,2.3,0.23]
[-2.234983,0.4469966,-0.2234983,0.02234983,-1.232,0.2464,-0.1232,0.01232,-23.0,4.6,-2.3,0.23]
1.576
--
⑨