ref: fec89394a4817f5cbf8e1f734da08b4ba6cc49cf
parent: b11dd3b27e83885cc6758eea53f9e175025ed7f4
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Fri Nov 3 15:13:48 EDT 2023
Make integer literals overloaded.
--- a/Makefile
+++ b/Makefile
@@ -47,6 +47,7 @@
$(BIN)/boot$(MHS): $(ALLSRC) $(TOOLS)/convertY.sh
rm -rf $(BOOTDIR)
$(GHCB) -c ghc/Primitives.hs
+ $(GHCB) -c ghc/PrimFromInteger.hs
$(GHCB) -c ghc/Data/Bool_Type.hs
$(GHCB) -c ghc/Data/Char_Type.hs
$(GHCB) -c ghc/Data/List_Type.hs
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
v4.0
-1287
-((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' _129) ((B _12) _1)) _300))) _5)) ((A :9 ((S (((S' C') _3) _4)) (((C' _13) _1) _299))) ((A :10 (((S' P) _2) (((C' _13) _1) _1047))) ((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' _126) _12) _118))) ((A :20 (((S' B) _14) (((C' _129) _12) _119))) ((A :21 _1120) ((A :22 ((B _1163) _21)) ((A :23 (((S' _1163) _21) I)) ((A :24 _1090) ((A :25 (_24 "undefined")) ((A :26 I) ((A :27 (((C' B) _1119) ((C _117) _26))) ((A :28 (((C' _27) ((_125 _1133) _98)) ((_117 (_34 _1135)) _97))) ((A :29 ((B ((S _1163) (_34 _1135))) _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) _299)))) (((S' (C' B)) ((B (B (C' B))) (B' _32))) (((S' (C' (C' B))) (B' _32)) (((C' B) (B' _34)) _300)))))) ((A :44 ((B (B Y)) (((S' B) (B' ((B P) ((C _34) _1047)))) (((C' (C' B)) ((B (B (C' B))) (B' _32))) BK)))) ((A :45 ((B T) ((C _34) _1047))) ((A :46 ((C _43) _118)) ((A :47 ((B _120) _32)) ((A :48 ((B C) ((B C') _32))) ((A :49 ((B _120) _48)) ((A :50 T) ((A :51 ((_124 ((B (B (_115 _50))) ((B ((C' C) _54)) (B P)))) (_128 _51))) ((A :52 (((((_11 _51) ((B (_115 _50)) P)) (_38 _53)) ((B (B (_115 _50))) (((C' B) ((B C) _54)) (BK _54)))) (_20 _52))) ((A :53 ((((_30 _52) ((B (B (_115 _50))) (((C' B) ((B C) _54)) (B _54)))) (_15 _52)) (_13 _52))) ((A :54 (T I)) ((A :55 ((B (_117 _357)) _54)) ((A :56 ((B (_115 _50)) (B (P _1047)))) ((A :57 ((B (_115 _50)) (BK (P _1047)))) ((A :58 ((_115 _50) ((S P) I))) ((A :59 ((B (_115 _50)) ((C (S' P)) I))) ((A :60 ((_102 ((C ((C S') _65)) I)) (_106 _60))) ((A :61 (((_1261 (K ((P (_1270 "False")) (_1270 "True")))) (_1266 _61)) (_1267 _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 ((_102 _1084) _1085)) ((A :75 ((((((((_334 _74) (_343 _75)) _1086) _1087) _1088) _1089) (_348 _75)) (_349 _75))) ((A :76 ((_102 _1094) (_106 _76))) ((A :77 ((((((((_334 _76) _1093) (((C' (C' (_103 _350))) _1093) _354)) (((C' (C' (_104 _350))) _1093) _356)) (((C' (C' (_103 _350))) _1093) _356)) (((C' (C' (_104 _350))) _1093) _356)) (_348 _77)) (_349 _77))) ((A :78 ((_69 (_79 #0)) (_79 #127))) ((A :79 _1095) ((A :80 _1096) ((A :81 (((S' _64) (_1087 #97)) ((C _1087) #122))) ((A :82 (((S' _64) (_1087 #65)) ((C _1087) #90))) ((A :83 (((S' _63) _81) _82)) ((A :84 (((S' _64) (_1087 #48)) ((C _1087) #57))) ((A :85 (((S' _63) _83) _84)) ((A :86 (((S' _64) (_1087 #32)) ((C _1087) #126))) ((A :87 (((S' _63) ((C (_103 _74)) #32)) (((S' _63) ((C (_103 _74)) #9)) ((C (_103 _74)) #10)))) ((A :88 ((S ((S (((S' _64) (_1087 #65)) ((C _1087) #90))) (_68 (((noMatch "lib/Data/Char.hs") #86) #9)))) ((B _79) (((C' (_317 _130)) (((C' (_318 _130)) _80) (_80 #65))) (_80 #97))))) ((A :89 ((S ((S (((S' _64) (_1087 #97)) ((C _1087) #97))) (_68 (((noMatch "lib/Data/Char.hs") #90) #9)))) ((B _79) (((C' (_317 _130)) (((C' (_318 _130)) _80) (_80 #97))) (_80 #65))))) ((A :90 (((_1261 (K ((C ((S ((C ==) #39)) ((B (_117 (_1269 #39))) (((C' _117) ((B _1270) _91)) (_1269 #39))))) (_1270 "'\92&''")))) (_1266 _90)) ((B (_117 (_1269 #34))) (Y ((B (P (_1269 #34))) (((S' C) ((B
\ No newline at end of file
+1291
+((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' _129) ((B _12) _1)) _301))) _5)) ((A :9 ((S (((S' C') _3) _4)) (((C' _13) _1) _300))) ((A :10 (((S' P) _2) (((C' _13) _1) _1049))) ((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' _126) _12) _118))) ((A :20 (((S' B) _14) (((C' _129) _12) _119))) ((A :21 _1122) ((A :22 ((B _1165) _21)) ((A :23 (((S' _1165) _21) I)) ((A :24 _1092) ((A :25 (_24 "undefined")) ((A :26 I) ((A :27 (((C' B) _1121) ((C _117) _26))) ((A :28 (((C' _27) ((_125 _1135) _98)) ((_117 (_34 _1137)) _97))) ((A :29 ((B ((S _1165) (_34 _1137))) _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) _300)))) (((S' (C' B)) ((B (B (C' B))) (B' _32))) (((S' (C' (C' B))) (B' _32)) (((C' B) (B' _34)) _301)))))) ((A :44 ((B (B Y)) (((S' B) (B' ((B P) ((C _34) _1049)))) (((C' (C' B)) ((B (B (C' B))) (B' _32))) BK)))) ((A :45 ((B T) ((C _34) _1049))) ((A :46 ((C _43) _118)) ((A :47 ((B _120) _32)) ((A :48 ((B C) ((B C') _32))) ((A :49 ((B _120) _48)) ((A :50 T) ((A :51 ((_124 ((B (B (_115 _50))) ((B ((C' C) _54)) (B P)))) (_128 _51))) ((A :52 (((((_11 _51) ((B (_115 _50)) P)) (_38 _53)) ((B (B (_115 _50))) (((C' B) ((B C) _54)) (BK _54)))) (_20 _52))) ((A :53 ((((_30 _52) ((B (B (_115 _50))) (((C' B) ((B C) _54)) (B _54)))) (_15 _52)) (_13 _52))) ((A :54 (T I)) ((A :55 ((B (_117 _356)) _54)) ((A :56 ((B (_115 _50)) (B (P _1049)))) ((A :57 ((B (_115 _50)) (BK (P _1049)))) ((A :58 ((_115 _50) ((S P) I))) ((A :59 ((B (_115 _50)) ((C (S' P)) I))) ((A :60 ((_102 ((C ((C S') _65)) I)) (_106 _60))) ((A :61 (((_1263 (K ((P (_1272 "False")) (_1272 "True")))) (_1268 _61)) (_1269 _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 ((_102 _1086) _1087)) ((A :75 ((((((((_333 _74) (_342 _75)) _1088) _1089) _1090) _1091) (_347 _75)) (_348 _75))) ((A :76 ((_102 _1096) (_106 _76))) ((A :77 ((((((((_333 _76) _1095) (((C' (C' (_103 _349))) _1095) _353)) (((C' (C' (_104 _349))) _1095) _355)) (((C' (C' (_103 _349))) _1095) _355)) (((C' (C' (_104 _349))) _1095) _355)) (_347 _77)) (_348 _77))) ((A :78 ((_69 (_79 #0)) (_79 #127))) ((A :79 _1097) ((A :80 _1098) ((A :81 (((S' _64) (_1089 #97)) ((C _1089) #122))) ((A :82 (((S' _64) (_1089 #65)) ((C _1089) #90))) ((A :83 (((S' _63) _81) _82)) ((A :84 (((S' _64) (_1089 #48)) ((C _1089) #57))) ((A :85 (((S' _63) _83) _84)) ((A :86 (((S' _64) (_1089 #32)) ((C _1089) #126))) ((A :87 (((S' _63) ((C (_103 _74)) #32)) (((S' _63) ((C (_103 _74)) #9)) ((C (_103 _74)) #10)))) ((A :88 ((S ((S (((S' _64) (_1089 #65)) ((C _1089) #90))) (_68 (((noMatch "lib/Data/Char.hs") #86) #9)))) ((B _79) (((C' (_318 _130)) (((C' (_319 _130)) _80) (_80 #65))) (_80 #97))))) ((A :89 ((S ((S (((S' _64) (_1089 #97)) ((C _1089) #97))) (_68 (((noMatch "lib/Data/Char.hs") #90) #9)))) ((B _79) (((C' (_318 _130)) (((C' (_319 _130)) _80) (_80 #97))) (_80 #65))))) ((A :90 (((_1263 (K ((C ((S ((C ==) #39)) ((B (_117 (_1271 #39))) (((C' _117) ((B _1272) _91)) (_1271 #39))))) (_1272 "'\92&''")))) (_1268 _90)) ((B (_117 (_1271 #34))) (Y ((B (P (_1271 #34))) (((S' C) ((B
\ No newline at end of file
--- a/ghc/Primitives.hs
+++ b/ghc/Primitives.hs
@@ -244,8 +244,8 @@
primRnf :: (NFData a) => a -> ()
primRnf = rnf
-fromInteger :: Integer -> Int
-fromInteger = P.fromInteger
+--fromInteger :: Integer -> Int
+--fromInteger = P.fromInteger
fromRational :: Rational -> Double
fromRational = P.fromRational
--- a/lib/Data/Double.hs
+++ b/lib/Data/Double.hs
@@ -6,6 +6,7 @@
import Data.Bool_Type
import Data.Eq
import Data.Fractional
+import Data.Integer
import Data.Ord
import Data.Num
import Text.Show
@@ -20,8 +21,7 @@
LT -> -1.0
EQ -> 0.0
GT -> 1.0
- fromInt = primDoubleFromInt
- fromInteger _ = error "Double.fromInteger not implemented"
+ fromInteger = _integerToDouble
instance Fractional Double where
(/) = primDoubleDiv
--- a/lib/Data/Int.hs
+++ b/lib/Data/Int.hs
@@ -24,7 +24,6 @@
LT -> -1
EQ -> 0
GT -> 1
- fromInt x = x
fromInteger = _integerToInt
instance Integral Int where
--- a/lib/Data/Integer.hs
+++ b/lib/Data/Integer.hs
@@ -2,9 +2,10 @@
-- See LICENSE file for full license.
module Data.Integer(
Integer,
+ readInteger,
_intToInteger,
_integerToInt,
- readInteger,
+ _integerToDouble,
_integerToIntList,
_intListToInteger,
) where
@@ -66,7 +67,6 @@
LT -> negOneI
EQ -> zeroI
GT -> oneI
- fromInt = _intToInteger
fromInteger x = x
instance Integral Integer where
@@ -92,6 +92,7 @@
| i == negate i = I Minus [0,0,2] -- we are at minBound::Int. XXX deal with this in a more portable way.
| otherwise = I Minus (f (negate i))
where
+ f :: Int -> [Int]
f 0 = []
f x = rem x maxD : f (quot x maxD)
@@ -151,7 +152,7 @@
-- Remove trailing 0s
trim0 :: [Digit] -> [Digit]
-trim0 = reverse . dropWhile (== 0) . reverse
+trim0 = reverse . dropWhile (== (0::Int)) . reverse
-- Is axs < ays?
ltW :: [Digit] -> [Digit] -> Bool
@@ -185,7 +186,7 @@
mulM :: [Digit] -> [Digit] -> [Digit]
mulM xs ys =
let rs = map (mulD zeroD xs) ys
- ss = zipWith (++) (map (`replicate` 0) [0..]) rs
+ ss = zipWith (++) (map (`replicate` (0::Int)) [0::Int ..]) rs
in foldl1 add ss
-- Signs:
@@ -196,7 +197,7 @@
quotRemI :: Integer -> Integer -> (Integer, Integer)
quotRemI _ (I _ []) = error "Integer: division by 0" -- n / 0
quotRemI (I _ []) _ = (I Plus [], I Plus []) -- 0 / n
-quotRemI (I sx xs) (I sy ys) | all (== 0) ys' =
+quotRemI (I sx xs) (I sy ys) | all (== (0::Int)) ys' =
-- All but the MSD are 0. Scale numerator accordingly and divide.
-- Then add back (the ++) the remainder we scaled off.
case quotRemD xs' y of
@@ -232,7 +233,7 @@
quotRemB xs ys =
let n = I Plus xs
d = I Plus ys
- a = I Plus $ replicate (length ys - 1) 0 ++ [last ys] -- only MSD of ys
+ a = I Plus $ replicate (length ys - (1::Int)) (0::Int) ++ [last ys] -- only MSD of ys
aq = quotI n a
ar = addI d oneI
loop q r =
@@ -314,7 +315,7 @@
-- This is used by the compiler to generate Integer literals.
_integerToIntList :: Integer -> [Int]
_integerToIntList (I Plus ds) = ds
-_integerToIntList (I Minus ds) = -1 : ds
+_integerToIntList (I Minus ds) = (-1::Int) : ds
_intListToInteger :: [Int] -> Integer
_intListToInteger (-1 : ds) = I Minus ds
--- a/lib/Data/Integer_Type.hs
+++ b/lib/Data/Integer_Type.hs
@@ -2,6 +2,7 @@
-- See LICENSE file for full license.
module Data.Integer_Type(module Data.Integer_Type) where
import Primitives
+--Yimport PrimFromInteger
import Data.List_Type
data Integer = I Sign [Digit]
@@ -11,7 +12,7 @@
type Digit = Int
maxD :: Digit
-maxD = (2147483648::Int) -- 2^31, this is used so multiplication of two digit doesn't overflow a 64 bit Int
+maxD = 2147483648 -- 2^31, this is used so multiplication of two digit doesn't overflow a 64 bit Int
_integerToInt :: Integer -> Int
_integerToInt (I sign ds) = s `primIntMul` i
@@ -21,8 +22,18 @@
[] -> 0::Int
[d1] -> d1
[d1,d2] -> d1 `primIntAdd` (maxD `primIntMul` d2)
- [d1,d2,d3] -> d1 `primIntAdd` (maxD `primIntMul` (d2 `primIntAdd` (maxD `primIntMul` d3)))
+ d1:d2:d3:_ -> d1 `primIntAdd` (maxD `primIntMul` (d2 `primIntAdd` (maxD `primIntMul` d3)))
s =
case sign of
Plus -> 1::Int
Minus -> 0 `primIntSub` 1
+
+_integerToDouble :: Integer -> Double
+_integerToDouble (I sign ds) = s `primDoubleMul` loop ds
+ where
+ loop [] = 0.0::Double
+ loop (i : is) = primDoubleFromInt i `primDoubleAdd` (primDoubleFromInt maxD `primDoubleMul` loop is)
+ s =
+ case sign of
+ Plus -> 1.0::Double
+ Minus -> 0.0 `primDoubleSub` 1.0
--- a/lib/Data/Integral.hs
+++ b/lib/Data/Integral.hs
@@ -20,6 +20,6 @@
n `rem` d = r where (q,r) = quotRem n d
n `div` d = q where (q,r) = divMod n d
n `mod` d = r where (q,r) = divMod n d
- divMod n d = if signum r == negate (signum d) then (q - fromInt 1, r + d) else qr
+ divMod n d = if signum r == negate (signum d) then (q - 1, r + d) else qr
where qr@(q,r) = quotRem n d
quotRem n d = (quot n d, rem n d)
--- a/lib/Data/List.hs
+++ b/lib/Data/List.hs
@@ -4,7 +4,7 @@
module Data.List,
module Data.List_Type
) where
-import Primitives as P
+import Primitives
import Control.Applicative
import Control.Error
import Control.Monad
@@ -86,15 +86,15 @@
foldl1 _ [] = error "foldl1"
foldl1 f (x : xs) = foldl f x xs
-minimum :: [P.Int] -> P.Int
+minimum :: [Int] -> Int
minimum [] = error "minimum"
minimum (x:ys) = foldr (\ y m -> if y < m then y else m) x ys
-sum :: [P.Int] -> P.Int
-sum = foldr (+) 0
+sum :: [Int] -> Int
+sum = foldr (+) (0::Int)
-product :: [P.Int] -> P.Int
-product = foldr (*) 1
+product :: [Int] -> Int
+product = foldr (*) (1::Int)
and :: [Bool] -> Bool
and = foldr (&&) True
@@ -108,33 +108,33 @@
all :: forall a . (a -> Bool) -> [a] -> Bool
all p = and . map p
-take :: forall a . P.Int -> [a] -> [a]
+take :: forall a . Int -> [a] -> [a]
take n arg =
- if n <= 0 then
+ if n <= (0::Int) then
[]
else
case arg of
[] -> []
- x : xs -> x : take (n - 1) xs
+ x : xs -> x : take (n - (1::Int)) xs
-drop :: forall a . P.Int -> [a] -> [a]
+drop :: forall a . Int -> [a] -> [a]
drop n arg =
- if n <= 0 then
+ if n <= (0::Int) then
arg
else
case arg of
[] -> []
- _ : xs -> drop (n - 1) xs
+ _ : xs -> drop (n - (1::Int)) xs
-length :: forall a . [a] -> P.Int
+length :: forall a . [a] -> Int
length =
-- Make it tail recursive and strict
let
rec r [] = r
rec r (_:xs) =
- let r' = r + 1
+ let r' = r + (1::Int)
in r' `primSeq` rec r' xs
- in rec 0
+ in rec (0::Int)
zip :: forall a b . [a] -> [b] -> [(a, b)]
zip = zipWith (\ x y -> (x, y))
@@ -178,7 +178,7 @@
isPrefixOfBy _ [] _ = True
isPrefixOfBy _ _ _ = False
-splitAt :: forall a . P.Int -> [a] -> ([a], [a])
+splitAt :: forall a . Int -> [a] -> ([a], [a])
splitAt n xs = (take n xs, drop n xs)
reverse :: forall a . [a] -> [a]
@@ -245,20 +245,20 @@
elemBy :: forall a . (a -> a -> Bool) -> a -> [a] -> Bool
elemBy eq a = any (eq a)
-enumFrom :: P.Int -> [P.Int]
+enumFrom :: Int -> [Int]
enumFrom n = n : enumFrom (n+1)
-enumFromThen :: P.Int -> P.Int -> [P.Int]
+enumFromThen :: Int -> Int -> [Int]
enumFromThen n m = from n
where d = m - n
from i = i : from (i+d)
-enumFromTo :: P.Int -> P.Int -> [P.Int]
+enumFromTo :: Int -> Int -> [Int]
enumFromTo l h = takeWhile (<= h) (enumFrom l)
-enumFromThenTo :: P.Int -> P.Int -> P.Int -> [P.Int]
+enumFromThenTo :: Int -> Int -> Int -> [Int]
enumFromThenTo l m h =
- if m - l > 0 then
+ if m > l then
takeWhile (<= h) (enumFromThen l m)
else
takeWhile (>= h) (enumFromThen l m)
@@ -303,7 +303,7 @@
nubBy _ [] = []
nubBy eq (x:xs) = x : nubBy eq (filter (\ y -> not (eq x y)) xs)
-replicate :: forall a . P.Int -> a -> [a]
+replicate :: forall a . Int -> a -> [a]
replicate n x = take n (repeat x)
repeat :: forall a . a -> [a]
@@ -324,14 +324,14 @@
deleteAllsBy eq = foldl (flip (deleteAllBy eq))
infixl 9 !!
-(!!) :: forall a . [a] -> P.Int -> a
+(!!) :: forall a . [a] -> Int -> a
(!!) axs i =
- if i < 0 then
+ if i < (0::Int) then
error "!!: <0"
else
let
nth _ [] = error "!!: empty"
- nth n (x:xs) = if n == 0 then x else nth (n - 1) xs
+ nth n (x:xs) = if n == (0::Int) then x else nth (n - (1::Int)) xs
in nth i axs
eqList :: forall a . (a -> a -> Bool) -> [a] -> [a] -> Bool
--- a/lib/Data/Num.hs
+++ b/lib/Data/Num.hs
@@ -2,6 +2,7 @@
-- See LICENSE file for full license.
module Data.Num(module Data.Num) where
import Primitives
+--Yimport PrimFromInteger
import Data.Integer_Type
infixl 6 +,-
@@ -15,9 +16,9 @@
abs :: a -> a
signum :: a -> a
fromInteger :: Integer -> a
- fromInt :: Int -> a
-
- negate x = fromInt 0 - x
+--Y{-+ negate x = 0 - x
+--Y-}
subtract :: forall a . Num a => a -> a -> a
subtract x y = y - x
--- a/lib/Data/Tuple.hs
+++ b/lib/Data/Tuple.hs
@@ -7,6 +7,7 @@
--Y-}
) where
import Primitives -- for ()
+--Yimport PrimFromInteger
import Data.Bool
import Data.Bounded
import Data.Eq
--- a/lib/Data/Word.hs
+++ b/lib/Data/Word.hs
@@ -6,7 +6,8 @@
import Data.Bounded
import Data.Char
import Data.Eq
-import Data.Int() -- insances only
+import Data.Int() -- instances only
+import Data.Integer
import Data.Integral
import Data.List
import Data.Num
@@ -17,8 +18,7 @@
(-) = primWordSub
(*) = primWordMul
abs x = x
- signum x = if x == fromInt 0 then fromInt 0 else fromInt 1
- fromInt = primUnsafeCoerce
+ signum x = if x == 0 then 0 else 1
fromInteger x = primUnsafeCoerce (_integerToInt x)
instance Integral Word where
--- a/lib/System/IO.hs
+++ b/lib/System/IO.hs
@@ -74,7 +74,7 @@
hGetChar :: Handle -> IO Char
hGetChar h = do
c <- primHGetChar h
- if c == negate 1 then
+ if c == (-1::Int) then
error "hGetChar: EOF"
else
return (chr c)
@@ -86,10 +86,10 @@
openFileM p m = do
let
n = case m of
- ReadMode -> 0
- WriteMode -> 1
- AppendMode -> 2
- ReadWriteMode -> 3
+ ReadMode -> 0::Int
+ WriteMode -> 1::Int
+ AppendMode -> 2::Int
+ ReadWriteMode -> 3::Int
hdl <- primOpenFile p n
if primIsNullHandle hdl then
return Nothing
@@ -115,30 +115,6 @@
print :: forall a . (Show a) => a -> IO ()
print a = putStrLn (show a)
-{--mapM :: forall a b . (a -> IO b) -> [a] -> IO [b]
-mapM f =
- let
- rec [] = return []
- rec (a : as) = do
- b <- f a
- bs <- rec as
- return (b : bs)
- in rec
-
-mapM_ :: forall a b . (a -> IO b) -> [a] -> IO ()
-mapM_ f =
- let
- rec [] = return ()
- rec (a : as) = do
- f a
- rec as
- in rec
-
-when :: Bool -> IO () -> IO ()
-when b io = if b then io else return ()
--}
-
putStr :: String -> IO ()
putStr = hPutStr stdout
@@ -169,7 +145,7 @@
hGetContents :: Handle -> IO String
hGetContents h = do
c <- primHGetChar h
- if c == negate 1 then do
+ if c == (-1::Int) then do
hClose h -- EOF, so close the handle
return ""
else do
--- a/lib/Text/Show.hs
+++ b/lib/Text/Show.hs
@@ -1,5 +1,6 @@
module Text.Show(module Text.Show) where
import Primitives
+--Yimport PrimFromInteger
import Data.Bool_Type
import Data.Char_Type
import Data.List_Type
--- a/lib/Text/String.hs
+++ b/lib/Text/String.hs
@@ -31,8 +31,8 @@
readInt :: String -> Int
readInt cs =
let
- rd = foldl (\ a c -> a * 10 + ord c - ord '0') 0
- in if head cs == '-' then 0 - rd (tail cs) else rd cs
+ rd = foldl (\ a c -> a * (10::Int) + ord c - ord '0') (0::Int)
+ in if head cs == '-' then (0::Int) - rd (tail cs) else rd cs
readDouble :: String -> Double
readDouble = primDoubleRead
--- a/src/Compat.hs
+++ b/src/Compat.hs
@@ -44,6 +44,16 @@
_intToInteger :: Int -> Integer
_intToInteger = fromIntegral
+_integerToDouble :: Integer -> Double
+_integerToDouble = fromIntegral
+
+-- Same as in Data.Integer
+_integerToIntList :: Integer -> [Int]
+_integerToIntList i | i < 0 = -1 : to (-i)
+ | otherwise = to i
+ where to 0 = []
+ to n = fromInteger r : to q where (q, r) = quotRem n 2147483648
+
xshowChar :: Char -> String
xshowChar = show
--- a/src/MicroHs/Desugar.hs
+++ b/src/MicroHs/Desugar.hs
@@ -13,7 +13,7 @@
--Ximport Control.Monad as S hiding(ap)
--Ximport Compat
--Ximport GHC.Stack
---Ximport Debug.Trace
+import Debug.Trace
import MicroHs.Expr
import MicroHs.Exp
@@ -170,6 +170,14 @@
in letRecE v (bnds $ mkTupleE es) $
bnds body
+encodeInteger :: Integer -> Exp
+encodeInteger i | -1000 < i && i < 1000 = -- XXX use better bounds
+-- trace ("*** small integer " ++ show i) $+ App (Var (mkIdent "Data.Integer._intToInteger")) (Lit (LInt (_integerToInt i)))
+ | otherwise =
+-- trace ("*** large integer " ++ show i) $+ App (Var (mkIdent "Data.Integer._intListToInteger")) (encodeList (map (Lit . LInt) (_integerToIntList i)))
+
dsExpr :: Expr -> Exp
dsExpr aexpr =
case aexpr of
@@ -177,6 +185,7 @@
EApp f a -> App (dsExpr f) (dsExpr a)
ELam qs -> dsEqns (getSLocExpr aexpr) qs
ELit _ (LChar c) -> Lit (LInt (ord c))
+ ELit _ (LInteger i) -> encodeInteger i
ELit _ l -> Lit l
ECase e as -> dsCase (getSLocExpr aexpr) e as
ELet ads e -> dsBinds ads (dsExpr e)
@@ -183,7 +192,7 @@
ETuple es -> Lam (mkIdent "$f") $ foldl App (Var $ mkIdent "$f") $ map dsExpr es
EIf e1 e2 e3 ->
app2 (dsExpr e1) (dsExpr e3) (dsExpr e2)
- EListish (LList es) -> foldr (app2 cCons) cNil $ map dsExpr es
+ EListish (LList es) -> encodeList $ map dsExpr es
EListish (LCompr e astmts) ->
case astmts of
[] -> dsExpr (EListish (LList [e]))
--- a/src/MicroHs/Exp.hs
+++ b/src/MicroHs/Exp.hs
@@ -11,6 +11,7 @@
encodeString,
app2, cCons, cNil, cFlip,
allVarsExp, freeVars,
+ encodeList,
) where
import Prelude --Xhiding((<>))
import Data.Char
@@ -21,7 +22,7 @@
--Ximport Control.DeepSeq
--Ximport Compat
--Yimport Primitives(NFData(..))
---import Debug.Trace
+import Debug.Trace
type PrimOp = String
@@ -139,7 +140,7 @@
(quoteString s ++)
else
toStringP (encodeString s)
- Lit (LInteger _) -> error "LInteger"
+ Lit (LInteger _) -> undefined
Lit l -> (showLit l ++)
Lam x e -> (("(\\" ++ showIdent x ++ " ") ++) . toStringP e . (")" ++) App f a -> ("(" ++) . toStringP f . (" " ++) . toStringP a . (")" ++)@@ -155,8 +156,10 @@
in '"' : concatMap achar s ++ ['"']
encodeString :: String -> Exp
-encodeString [] = cNil
-encodeString (c:cs) = app2 cCons (Lit (LInt (ord c))) (encodeString cs)
+encodeString = encodeList . map (Lit . LInt . ord)
+
+encodeList :: [Exp] -> Exp
+encodeList = foldr (app2 cCons) cNil
compileOpt :: Exp -> Exp
compileOpt = improveT . compileExp
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -1410,25 +1410,36 @@
EOper e ies -> do e' <- tcOper e ies; tcExpr mt e'
ELam qs -> tcExprLam mt qs
ELit loc' l -> do
- case l of
- LInteger i -> do
- let getExpected (Infer _) = pure Nothing
- getExpected (Check t) = do
- t' <- derefUVar t >>= expandSyn
- case t' of
- EVar i -> pure (Just i)
- _ -> pure Nothing
- mex <- getExpected mt
- case mex of
- -- Convert to Int in the compiler, that way (99::Int) will never involve fromInteger
- -- (which is not always in scope).
- Just v | v == mkIdent nameInt -> tcLit mt loc' (LInt (fromInteger i))
- _ -> do
- (f, ft) <- tInferExpr (EVar (mkIdentSLoc loc' "fromInteger")) -- XXX should have this qualified somehow
- (_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
- _ -> tcLit mt loc' l
+ tcm <- gets tcMode
+-- traceM ("tcExpr EApp: " ++ showExpr f ++ " :: " ++ showEType ft)+ case tcm of
+ -- XXX This is temporary hack. Don't allow polymorphic constrants in patterns
+ TCPat ->
+ case l of
+ LInteger i -> tcLit mt loc' (LInt (_integerToInt i))
+ _ -> tcLit mt loc' l
+ _ ->
+ 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
+ -- (which is not always in scope).
+ Just v | v == mkIdent nameInt -> tcLit mt loc' (LInt (_integerToInt i))
+ | v == mkIdent nameDouble -> tcLit mt loc' (LDouble (_integerToDouble i))
+ _ -> do
+ (f, ft) <- tInferExpr (EVar (mkIdentSLoc loc' "fromInteger")) -- XXX should have this qualified somehow
+ (_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
+ _ -> tcLit mt loc' l
ECase a arms -> do
(ea, ta) <- tInferExpr a
tt <- tGetExpType mt
--- a/tests/Arith.hs
+++ b/tests/Arith.hs
@@ -3,6 +3,6 @@
main :: IO ()
main = do
- putStrLn $ show [ op x y | x <- [0 - 5,0 - 2,0 - 1,0,1,2,5], y <- [0 - 5,0 - 2,0 - 1,0,1,2,5], op <- [(+),( - ),(*)] ]
- putStrLn $ show [ op x y | x <- [0 - 5,0 - 2,0 - 1,0,1,2,5], y <- [0 - 5,0 - 2,0 - 1,1,2,5], op <- [quot, rem] ]
- putStrLn $ show [ op x y | x <- [0 - 5,0 - 2,0 - 1,0,1,2,5], y <- [0 - 5,0 - 2,0 - 1,0,1,2,5], op <- [(==),(/=),(<),(<=),(>),(>=)] ]
+ putStrLn $ show [ op x y | x <- [0 - 5,0 - 2,0 - 1,0,1,2,5]::[Int], y <- [0 - 5,0 - 2,0 - 1,0,1,2,5::Int], op <- [(+),( - ),(*)] ]
+ putStrLn $ show [ op x y | x <- [0 - 5,0 - 2,0 - 1,0,1,2,5]::[Int], y <- [0 - 5,0 - 2,0 - 1,1,2,5::Int], op <- [quot, rem] ]
+ putStrLn $ show [ op x y | x <- [0 - 5,0 - 2,0 - 1,0,1,2,5]::[Int], y <- [0 - 5,0 - 2,0 - 1,0,1,2,5::Int], op <- [(==),(/=),(<),(<=),(>),(>=)] ]
--- a/tests/Case.hs
+++ b/tests/Case.hs
@@ -8,10 +8,10 @@
putStrLn $ show $ f2 True
-- putStrLn $ showInt $ f3 False
putStrLn $ show $ map f4 [R,G,B]
- putStrLn $ show $ f5 [(3,4)]
+ putStrLn $ show $ f5 [(3::Int,4::Int)]
--putStrLn $ showInt $ f6 [(3,4)]
- putStrLn $ show $ [ i | Just i <- [Just 1, Nothing, Just 2] ]
- (x,y) <- return (2,3)
+ putStrLn $ show $ [ i | Just i <- [Just (1::Int), Nothing, Just 2] ]
+ (x,y) <- return (2::Int,3::Int)
putStrLn $ show $ x + y
f1 :: Bool -> Bool
--- a/tests/Class.hs
+++ b/tests/Class.hs
@@ -38,8 +38,8 @@
main :: IO ()
main = do
- putStrLn $ show $ f 5
- putStrLn $ show $ g 5
- putStrLn $ show $ h 5 'a'
- putStrLn $ show $ f [88]
- putStrLn $ show $ f (1, 'a')
+ putStrLn $ show $ f (5::Int)
+ putStrLn $ show $ g (5::Int)
+ putStrLn $ show $ h (5::Int) 'a'
+ putStrLn $ show $ f [88::Int]
+ putStrLn $ show $ f (1::Int, 'a')
--- a/tests/Eq.hs
+++ b/tests/Eq.hs
@@ -4,18 +4,17 @@
main :: IO ()
main = do
- putStrLn $ show [1==1, 'a'=='a', 1.1==1.1,
+ putStrLn $ show [1==(1::Int), 'a'=='a', 1.1==(1.1::Double),
True==True, False==False,
- (Nothing::Maybe Int)==Nothing, Just 1 == Just 1,
- [1,2,3] == [1,2,3],
- (1,2) == (1,2),
+ (Nothing::Maybe Int)==Nothing, Just (1::Int) == Just 1,
+ [1,2,3] == [1,2,3::Int],
+ (1,2) == (1::Int,2::Int),
(Left 1 :: Either Int Char) == Left 1, (Right 'a' :: Either Int Char) == Right 'a'
]
- putStrLn $ show [1==2, 'a'=='b', 1.1==1.2,
+ putStrLn $ show [1==(2::Int), 'a'=='b', 1.1==(1.2::Double),
True==False, False==True,
- Nothing==Just 1, Just 1 == Nothing,
- [1,2,3] == [1,2,4],
- (1,2) == (1,4),
- Left 1 == Right 'a', Right 'a' == Left 1
+ Nothing==Just (1::Int), Just (1::Int) == Nothing,
+ [1,2,3] == [1,2,4::Int],
+ (1,2) == (1::Int,4::Int),
+ Left (1::Int) == Right 'a', Right 'a' == Left (1::Int)
]
-
--- a/tests/IOTest.hs
+++ b/tests/IOTest.hs
@@ -37,12 +37,12 @@
putStrLn (show s)
writeSerialized "f.tmp" f
g <- readSerialized "f.tmp"
- putStrLn $ show $ (g 5 :: Int)
+ putStrLn $ show $ (g (5::Int) :: Int)
foo
- putStrLn $ show $ trace "tracing" 5
+ putStrLn $ show $ trace "tracing" (5::Int)
as <- getArgs
putStrLn $ show as
- putStrLn $ show $ seq (1 + 2) 5
- putStrLn $ show $ seq (1 + trace "seq" 2) 5
+ putStrLn $ show $ seq ((1::Int) + (2::Int)) (5::Int)
+ putStrLn $ show $ seq ((1::Int) + trace "seq" (2::Int)) (5::Int)
tend <- getTimeMilli
putStrLn $ show (tend - tstart) ++ "ms execution time"
--- a/tests/Misc.hs
+++ b/tests/Misc.hs
@@ -8,4 +8,4 @@
main :: IO ()
main = do
- print $ first (10,20)
+ print $ first (10::Int,20::Int)
--- a/tests/Rank2.hs
+++ b/tests/Rank2.hs
@@ -2,10 +2,10 @@
import Prelude
f :: (forall a . a -> a) -> (Int, Bool)
-f i = (i 1, i True)
+f i = (i (1::Int), i True)
g :: (forall a . a -> Int -> a) -> (Int, Bool)
-g c = (c 1 1, c True 1)
+g c = (c (1::Int) (1::Int), c True (1::Int))
data Id = Id (forall a . a -> a)
@@ -17,4 +17,4 @@
putStrLn $ show $ f id
putStrLn $ show $ g const
case iD of
- Id i -> putStrLn $ show (i 1, i True)
+ Id i -> putStrLn $ show (i (1::Int), i True)
--- a/tests/StringTest.hs
+++ b/tests/StringTest.hs
@@ -5,18 +5,18 @@
main = do
putStrLn $ if (==) "abc" "abc" then "yes" else "no"
putStrLn $ if (==) "abc" "adc" then "yes" else "no"
- putStrLn $ show 1234
- putStrLn $ show 0
- putStrLn $ show (negate 567)
+ putStrLn $ show (1234::Int)
+ putStrLn $ show (0::Int)
+ putStrLn $ show (negate (567::Int))
putStrLn $ show 'x'
putStrLn $ show '\n'
putStrLn $ show False
-- putStrLn $ showUnit ()
- putStrLn $ show [1,20,3]
- putStrLn $ show [1]
+ putStrLn $ show [1,20,3::Int]
+ putStrLn $ show [1::Int]
putStrLn $ show ([] :: [Int])
- putStrLn $ show (123, 'a')
+ putStrLn $ show (123::Int, 'a')
putStrLn $ show (Nothing :: Maybe Int)
- putStrLn $ show (Just 890)
+ putStrLn $ show (Just 890 :: Maybe Int)
putStrLn $ show (Left 678 :: Either Int Bool)
putStrLn $ show (Right True :: Either Int Bool)
--- a/tests/Word.hs
+++ b/tests/Word.hs
@@ -4,10 +4,10 @@
main :: IO ()
main = do
- putStrLn $ show 4294967295
- putStrLn $ show (W.intToWord 1000)
+ putStrLn $ show (4294967295::Int)
+ putStrLn $ show (W.intToWord (1000::Int))
putStrLn $ show twoTo32M1
putStrLn $ show $ (*) twoTo32M1 twoTo32M1
twoTo32M1 :: W.Word
-twoTo32M1 = W.intToWord 4294967295
+twoTo32M1 = W.intToWord (4294967295::Int)
--
⑨