ref: dc946751d9458253ab1f281aa3668df7eab0b296
parent: 03ee7c5fc06ddfb7bc2dcd24cb0904159f68ae33
author: Lennart Augustsson <lennart@augustsson.net>
date: Sat Nov 4 07:03:54 EDT 2023
More instances
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
v4.0
-1393
-((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)) _388))) _5)) ((A :9 ((S (((S' C') _3) _4)) (((C' _13) _1) _387))) ((A :10 (((S' P) _2) (((C' _13) _1) _1151))) ((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 _1224) ((A :22 ((B _1267) _21)) ((A :23 (((S' _1267) _21) I)) ((A :24 _1194) ((A :25 (_24 "undefined")) ((A :26 I) ((A :27 (((C' B) _1223) ((C _196) _26))) ((A :28 (((C' _27) ((_205 _1237) _108)) ((_196 (_34 _1239)) _107))) ((A :29 ((B ((S _1267) (_34 _1239))) _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) _387)))) (((S' (C' B)) ((B (B (C' B))) (B' _32))) (((S' (C' (C' B))) (B' _32)) (((C' B) (B' _34)) _388)))))) ((A :44 ((B (B Y)) (((S' B) (B' ((B P) ((C _34) _1151)))) (((C' (C' B)) ((B (B (C' B))) (B' _32))) BK)))) ((A :45 ((B T) ((C _34) _1151))) ((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 _459)) _54)) ((A :56 ((B (_194 _50)) (B (P _1151)))) ((A :57 ((B (_194 _50)) (BK (P _1151)))) ((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 (((_1365 (K ((P (_1374 "False")) (_1374 "True")))) (_1370 _61)) (_1371 _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 _1188) _1189)) ((A :75 ((((((((_420 _74) (_429 _75)) _1190) _1191) _1192) _1193) (_434 _75)) (_435 _75))) ((A :76 ((_134 _1198) (_138 _76))) ((A :77 ((((((((_420 _76) _1197) (((C' (C' (_135 _436))) _1197) _440)) (((C' (C' (_136 _436))) _1197) _442)) (((C' (C' (_135 _436))) _1197) _442)) (((C' (C' (_136 _436))) _1197) _442)) (_434 _77)) (_435 _77))) ((A :78 ((_69 (_79 #0)) (_79 #127))) ((A :79 _1199) ((A :80 _1200) ((A :81 (((S' _64) (_1191 #97)) ((C _1191) #122))) ((A :82 (((S' _64) (_1191 #65)) ((C _1191) #90))) ((A :83 (((S' _63) _81) _82)) ((A :84 (((S' _64) (_1191 #48)) ((C _1191) #57))) ((A :85 (((S' _63) _83) _84)) ((A :86 (((S' _64) (_1191 #32)) ((C _1191) #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) (_1191 #65)) ((C _1191) #90))) (_68 (((noMatch "lib/Data/Char.hs") #72) #9)))) ((B _79) (((C' (_405 _210)) (((C' (_406 _210)) _80) (_80 #65))) (_80 #97))))) ((A :89 ((S ((S (((S' _64) (_1191 #97)) ((C _1191) #97))) (_68 (((noMatch "lib/Data/Char.hs") #76) #9)))) ((B _79) (((C' (_405 _210)) (((C' (_406 _210)) _80) (_80 #97))) (_80 #65))))) ((A :90 (((_1365 (K ((C ((S ((C ==) #39)) ((B (_196 (_1373 #39))) (((C' _196) ((B _1374) _91)) (_1373 #39))))) (_1374 "'\92&''")))) (_1370 _90)) ((B (_196 (_1373 #34))) (Y ((B (P (_1373 #34))) (((S' C) ((
\ No newline at end of file
+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)) _391))) _5)) ((A :9 ((S (((S' C') _3) _4)) (((C' _13) _1) _390))) ((A :10 (((S' P) _2) (((C' _13) _1) _1156))) ((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 _1231) ((A :22 ((B _1274) _21)) ((A :23 (((S' _1274) _21) I)) ((A :24 _1201) ((A :25 (_24 "undefined")) ((A :26 I) ((A :27 (((C' B) _1230) ((C _196) _26))) ((A :28 (((C' _27) ((_205 _1244) _108)) ((_196 (_34 _1246)) _107))) ((A :29 ((B ((S _1274) (_34 _1246))) _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) _390)))) (((S' (C' B)) ((B (B (C' B))) (B' _32))) (((S' (C' (C' B))) (B' _32)) (((C' B) (B' _34)) _391)))))) ((A :44 ((B (B Y)) (((S' B) (B' ((B P) ((C _34) _1156)))) (((C' (C' B)) ((B (B (C' B))) (B' _32))) BK)))) ((A :45 ((B T) ((C _34) _1156))) ((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 _462)) _54)) ((A :56 ((B (_194 _50)) (B (P _1156)))) ((A :57 ((B (_194 _50)) (BK (P _1156)))) ((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 (((_1372 (K ((P (_1381 "False")) (_1381 "True")))) (_1377 _61)) (_1378 _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 _1195) _1196)) ((A :75 ((((((((_423 _74) (_432 _75)) _1197) _1198) _1199) _1200) (_437 _75)) (_438 _75))) ((A :76 ((_134 _1205) (_138 _76))) ((A :77 ((((((((_423 _76) _1204) (((C' (C' (_135 _439))) _1204) _443)) (((C' (C' (_136 _439))) _1204) _445)) (((C' (C' (_135 _439))) _1204) _445)) (((C' (C' (_136 _439))) _1204) _445)) (_437 _77)) (_438 _77))) ((A :78 ((_69 (_79 #0)) (_79 #127))) ((A :79 _1206) ((A :80 _1207) ((A :81 (((S' _64) (_1198 #97)) ((C _1198) #122))) ((A :82 (((S' _64) (_1198 #65)) ((C _1198) #90))) ((A :83 (((S' _63) _81) _82)) ((A :84 (((S' _64) (_1198 #48)) ((C _1198) #57))) ((A :85 (((S' _63) _83) _84)) ((A :86 (((S' _64) (_1198 #32)) ((C _1198) #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) (_1198 #65)) ((C _1198) #90))) (_68 (((noMatch "lib/Data/Char.hs") #72) #9)))) ((B _79) (((C' (_408 _210)) (((C' (_409 _210)) _80) (_80 #65))) (_80 #97))))) ((A :89 ((S ((S (((S' _64) (_1198 #97)) ((C _1198) #97))) (_68 (((noMatch "lib/Data/Char.hs") #76) #9)))) ((B _79) (((C' (_408 _210)) (((C' (_409 _210)) _80) (_80 #97))) (_80 #65))))) ((A :90 (((_1372 (K ((C ((S ((C ==) #39)) ((B (_196 (_1380 #39))) (((C' _196) ((B _1381) _91)) (_1380 #39))))) (_1381 "'\92&''")))) (_1377 _90)) ((B (_196 (_1380 #34))) (Y ((B (P (_1380 #34))) (((S' C) ((
\ No newline at end of file
--- a/lib/Data/Int.hs
+++ b/lib/Data/Int.hs
@@ -35,8 +35,8 @@
{-instance Bounded Int where
- minBound = -9223372036854775808 -- -2^63
- maxBound = 9223372036854775807 -- 2^63-1
+ minBound = -9223372036854775808::Int -- -2^63
+ maxBound = 9223372036854775807::Int -- 2^63-1
-}
instance Real Int where
--- a/lib/Data/Integer.hs
+++ b/lib/Data/Integer.hs
@@ -5,7 +5,10 @@
readInteger,
_intToInteger,
_integerToInt,
+ _wordToInteger,
+ _integerToWord,
_integerToDouble,
+ _integerToRational,
_integerToIntList,
_intListToInteger,
) where
--- a/lib/Data/Integer_Type.hs
+++ b/lib/Data/Integer_Type.hs
@@ -39,6 +39,15 @@
Plus -> 1::Int
Minus -> 0 `primIntSub` 1
+_wordToInteger :: Word -> Integer
+_wordToInteger i = I Plus (f i)
+ where
+ f :: Word -> [Int]
+ f x = if x `primWordEQ` (0::Word) then [] else primWordToInt (primWordRem x (primIntToWord maxD)) : f (primWordQuot x (primIntToWord maxD))
+
+_integerToWord :: Integer -> Word
+_integerToWord x = primIntToWord (_integerToInt x)
+
_integerToDouble :: Integer -> Double
_integerToDouble (I sign ds) = s `primDoubleMul` loop ds
where
--- a/lib/Data/Integral.hs
+++ b/lib/Data/Integral.hs
@@ -53,3 +53,6 @@
where pow x y | y == 0 = 1
| even y = pow (x * x) (y `quot` 2)
| otherwise = x * pow (x * x) (y `quot` 2)
+
+fromIntegral :: forall a b . (Integral a, Num b) => a -> b
+fromIntegral x = fromInteger (toInteger x)
--- a/lib/Data/Word.hs
+++ b/lib/Data/Word.hs
@@ -13,6 +13,7 @@
import Data.List
import Data.Num
import Data.Ord
+import Data.Real
import Text.Show
instance Num Word where
@@ -21,21 +22,40 @@
(*) = primWordMul
abs x = x
signum x = if x == 0 then 0 else 1
- fromInteger x = intToWord (_integerToInt x)
+ fromInteger x = primIntToWord (_integerToInt x)
instance Integral Word where
quot = primWordQuot
rem = primWordRem
- toInteger x = _intToInteger (wordToInt x)
+ toInteger = _wordToInteger
-{-instance Bounded Word where
- minBound = 0
- maxBound = 18446744073709551615 -- 2^64-1
--}
+ minBound = 0::Word
+ maxBound = 18446744073709551615::Word -- 2^64-1
---------------------------------
-
+instance Real Word where
+ toRational i = _integerToRational (_wordToInteger i)
+
+--------------------------------
+
+instance Enum Word where
+ succ x = x + 1
+ pred x = x - 1
+ toEnum = primIntToWord
+ fromEnum = primWordToInt
+ enumFrom n = n : enumFrom (n+1)
+ enumFromThen n m = from n
+ where d = m - n
+ from i = i : from (i+d)
+ enumFromTo l h = takeWhile (<= h) (enumFrom l)
+ enumFromThenTo l m h =
+ if m > l then
+ takeWhile (<= h) (enumFromThen l m)
+ else
+ takeWhile (>= h) (enumFromThen l m)
+
+--------------------------------
+
instance Eq Word where
(==) = primWordEQ
(/=) = primWordNE
@@ -47,17 +67,11 @@
(>=) = primWordGE
instance Enum Word where
- toEnum = intToWord
- fromEnum = wordToInt
+ toEnum = primIntToWord
+ fromEnum = primWordToInt
-intToWord :: Int -> Word
-intToWord = primUnsafeCoerce
-
-wordToInt :: Word -> Int
-wordToInt = primUnsafeCoerce
+--------------------------------
---------------------------------
-
instance Show Word where
show = showWord
where
@@ -64,7 +78,7 @@
showWord :: Word -> String
showWord n =
let
- c = chr ((ord '0') + (wordToInt (rem n (intToWord 10))))
- in case n < intToWord 10 of
- False -> showWord (quot n (intToWord 10)) ++ [c]
+ c = chr (ord '0' + primWordToInt (rem n (10::Word)))
+ in case n < (10::Word) of
+ False -> showWord (quot n (10::Word)) ++ [c]
True -> [c]
--- a/lib/Primitives.hs
+++ b/lib/Primitives.hs
@@ -99,6 +99,11 @@
primWordGE :: Word -> Word -> Bool
primWordGE = primitive ">="
+primWordToInt :: Word -> Int
+primWordToInt = primitive "I"
+primIntToWord :: Int -> Word
+primIntToWord = primitive "I"
+
primCharEQ :: Char -> Char -> Bool
primCharEQ = primitive "=="
primCharNE :: Char -> Char -> Bool
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -35,6 +35,9 @@
nameInt :: String
nameInt = "Primitives.Int"
+nameWord :: String
+nameWord = "Primitives.Word"
+
nameDouble :: String
nameDouble = "Primitives.Double"
@@ -1432,9 +1435,10 @@
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))
- | v == mkIdent nameInteger -> tcLit mt loc' l
+ Just v | v == mkIdent nameInt -> tcLit mt loc' (LInt (_integerToInt i))
+ | v == mkIdent nameWord -> tcLit' mt loc' (LInt (_integerToInt i)) (tConI loc' nameWord)
+ | v == mkIdent nameDouble -> tcLit mt loc' (LDouble (_integerToDouble i))
+ | v == mkIdent nameInteger -> tcLit mt loc' l
_ -> do
(f, ft) <- tInferExpr (EVar (mkIdentSLoc loc' "fromInteger")) -- XXX should have this qualified somehow
(_at, rt) <- unArrow loc ft
@@ -1559,17 +1563,20 @@
enum loc f = foldl EApp (EVar (mkIdentSLoc loc ("enum" ++ f)))tcLit :: Expected -> SLoc -> Lit -> T Expr
---tcLit mt loc (LInteger i) = tcLit mt loc (LInt (fromInteger i))
+tcLit mt loc l@(LPrim _) = newUVar >>= tcLit' mt loc l
tcLit mt loc l = do
- let lit t = instSigma loc (ELit loc l) t mt
- case l of
- LInt _ -> lit (tConI loc nameInt)
- LInteger _ -> lit (tConI loc nameInteger)
- LDouble _ -> lit (tConI loc nameDouble)
- LChar _ -> lit (tConI loc nameChar)
- LStr _ -> lit (tApp (tList loc) (tConI loc nameChar))
- LPrim _ -> newUVar >>= lit -- pretend it is anything
- LForImp _ -> impossible
+ let t =
+ case l of
+ LInt _ -> tConI loc nameInt
+ LInteger _ -> tConI loc nameInteger
+ LDouble _ -> tConI loc nameDouble
+ LChar _ -> tConI loc nameChar
+ LStr _ -> tApp (tList loc) (tConI loc nameChar)
+ _ -> impossible
+ tcLit' mt loc l t
+
+tcLit' :: Expected -> SLoc -> Lit -> EType -> T Expr
+tcLit' mt loc l t = instSigma loc (ELit loc l) t mt
tcOper :: --XHasCallStack =>
Expr -> [(Ident, Expr)] -> T Expr
--- a/tests/Word.hs
+++ b/tests/Word.hs
@@ -1,13 +1,13 @@
module Word(main) where
import Prelude
-import qualified Data.Word as W
+import Data.Word
main :: IO ()
main = do
putStrLn $ show (4294967295::Int)
- putStrLn $ show (W.intToWord (1000::Int))
+ putStrLn $ show (1000::Word)
putStrLn $ show twoTo32M1
putStrLn $ show $ (*) twoTo32M1 twoTo32M1
-twoTo32M1 :: W.Word
-twoTo32M1 = W.intToWord (4294967295::Int)
+twoTo32M1 :: Word
+twoTo32M1 = 4294967295::Word
--
⑨