ref: b82c264918bc202f5d0756cd860598cac3f3a6a2
parent: 8093dbcceebfbb1872213c09abbb2bffb06492e3
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Fri Nov 3 17:59:40 EDT 2023
Add more numeric classes.
--- /dev/null
+++ b/ghc/PrimFromInteger.hs
@@ -1,0 +1,5 @@
+module PrimFromInteger where
+import qualified Prelude as P
+
+fromInteger :: P.Integer -> P.Int
+fromInteger = P.fromInteger
--- a/lib/Data/Double.hs
+++ b/lib/Data/Double.hs
@@ -8,6 +8,7 @@
import Data.Fractional
import Data.Integer
import Data.Ord
+import Data.Ratio
import Data.Num
import Text.Show
@@ -25,7 +26,7 @@
instance Fractional Double where
(/) = primDoubleDiv
- fromDouble x = x
+ fromRational x = fromInteger (numerator x) `primDoubleDiv` fromInteger (denominator x) -- XXX This isn't right
instance Eq Double where
(==) = primDoubleEQ
--- a/lib/Data/Fractional.hs
+++ b/lib/Data/Fractional.hs
@@ -2,12 +2,12 @@
-- See LICENSE file for full license.
module Data.Fractional(module Data.Fractional) where
import Primitives
+import Data.Ratio_Type
import Data.Num
class Num a => Fractional a where
(/) :: a -> a -> a
recip :: a -> a
--- fromRational :: Rational -> a
- fromDouble :: Double -> a
+ fromRational :: Rational -> a
- recip x = fromDouble 1.0 / x
+ recip x = 1 / x
--- a/lib/Data/Integral.hs
+++ b/lib/Data/Integral.hs
@@ -2,6 +2,7 @@
-- See LICENSE file for full license.
module Data.Integral(module Data.Integral) where
import Primitives
+import Data.Bool
import Data.Eq
import Data.Integer_Type
import Data.Num
@@ -24,3 +25,14 @@
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)
+
+gcd :: forall a . (Integral a) => a -> a -> a
+gcd x y = gcd' (abs x) (abs y)
+ where gcd' a b = if b == 0 then a else gcd' b (a `rem` b)
+
+lcm :: forall a . (Integral a) => a -> a -> a
+lcm x y =
+ if x == 0 || y == 0 then
+ 0
+ else
+ abs ((x `quot` (gcd x y)) * y)
--- /dev/null
+++ b/lib/Data/Ratio.hs
@@ -1,0 +1,83 @@
+module Data.Ratio(
+ Ratio, Rational,
+ (%),
+ numerator, denominator,
+ rationalInfinity,
+ rationalNaN,
+ Rational,
+ ) where
+import Primitives
+import Control.Error
+import Data.Bool
+import Data.Eq
+import Data.Fractional
+import Data.Function
+import Data.Int
+import Data.Integer
+import Data.Integral
+import Data.Num
+import Data.Ord
+import Data.Ratio_Type
+import Text.Show
+
+{- in Data.Ratio_Type+data Ratio a = (:%) a a -- XXX should be strict
+
+type Rational = Ratio Integer
+-}
+
+instance forall a . Eq a => Eq (Ratio a) where
+ (x :% y) == (x' :% y') = x == x' && y == y'
+
+instance forall a . (Integral a, Ord a) => Ord (Ratio a) where
+ (x :% y) <= (x' :% y') = x * y' <= x' * y
+ (x :% y) < (x' :% y') = x * y' < x' * y
+ (x :% y) >= (x' :% y') = x * y' >= x' * y
+ (x :% y) > (x' :% y') = x * y' > x' * y
+
+instance forall a . (Integral a) => Num (Ratio a) where
+ (x:%y) + (x':%y') = reduce (x*y' + x'*y) (y*y')
+ (x:%y) - (x':%y') = reduce (x*y' - x'*y) (y*y')
+ (x:%y) * (x':%y') = reduce (x * x') (y * y')
+ negate (x:%y) = (negate x) :% y
+ abs (x:%y) = abs x :% y
+ signum (x:%_) = signum x :% 1
+ fromInteger x = fromInteger x :% 1
+
+instance forall a . (Integral a, Ord a) => Fractional (Ratio a) where
+ (x:%y) / (x':%y') = (x*y') % (y*x')
+ recip (x:%y)
+ | 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
+
+instance forall a . (Show a) => Show (Ratio a) where
+ showsPrec p (x:%y) = showParen (p > 7) $
+ showsPrec 8 x .
+ showString " % " .
+ showsPrec 8 y
+
+rationalInfinity :: Rational
+rationalInfinity = 1 :% 0
+
+rationalNaN :: Rational
+rationalNaN = 0 :% 0
+
+infixl 7 %
+(%) :: forall a . (Integral a) => a -> a -> Ratio a
+x % y = reduce (x * signum y) (abs y)
+
+reduce :: forall a . (Integral a) => a -> a -> Ratio a
+reduce x y =
+ if y == 0 then
+ error "Data.Ratio.%: 0 denominator"
+ else
+ let d = gcd x y
+ in (x `quot` d) :% (y `quot` d)
+
+numerator :: forall a . Ratio a -> a
+numerator (x :% _) = x
+
+denominator :: forall a . Ratio a -> a
+denominator (_ :% y) = y
--- /dev/null
+++ b/lib/Data/Ratio_Type.hs
@@ -1,0 +1,8 @@
+module Data.Ratio_Type(module Data.Ratio_Type) where
+import Primitives
+import Data.Integer_Type
+
+data Ratio a = (:%) a a -- XXX should be strict
+
+type Rational = Ratio Integer
+
--- /dev/null
+++ b/lib/Data/Real.hs
@@ -1,0 +1,8 @@
+module Data.Real(module Data.Real) where
+import Primitives
+import Data.Num
+import Data.Int
+import Data.Ratio
+
+class (Num a, Ord a) => Real a where
+ toRational :: a -> Rational
--- a/src/MicroHs/Expr.hs
+++ b/src/MicroHs/Expr.hs
@@ -277,12 +277,14 @@
-- Very partial implementation of Expr equality.
-- It is only used to compare instances, so this suffices.
-eqExpr :: Expr -> Expr -> Bool
+eqExpr :: --XHasCallStack =>
+ Expr -> Expr -> Bool
eqExpr (EVar i) (EVar i') = i == i'
eqExpr (EVar _) (EApp _ _) = False
eqExpr (EApp f a) (EApp f' a') = eqExpr f f' && eqExpr a a'
eqExpr (EApp _ _) (EVar _) = False
-eqExpr _ _ = error "eqExpr: unimplemented"
+eqExpr _ _ = False -- XXX good enough for instances
+--eqExpr e1 e2 = error $ "eqExpr: unimplemented " ++ showExpr e1 ++ " == " ++ showExpr e2
---------------------------------
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -339,7 +339,7 @@
mergeInstInfo (InstInfo m1 l1) (InstInfo m2 l2) =
let
m = foldr (uncurry $ M.insertWith mrg) m2 (M.toList m1)
- mrg e1 e2 = if eqExpr e1 e2 then e1 else errorMessage (getSLocExpr e1) $ "Multiple instances: " ++ showSLoc (getSLocExpr e2)
+ mrg e1 _e2 = e1 -- XXX improve this if eqExpr e1 e2 then e1 else errorMessage (getSLocExpr e1) $ "Multiple instances: " ++ showSLoc (getSLocExpr e2)
l = unionBy eqInstDict l1 l2
in InstInfo m l
--
⑨