shithub: MicroHs

Info  •  Files  •  Log  •  Branches

Add RealFrac

--- a/TODO

+++ b/TODO

@@ -42,3 +42,4 @@

   - do everything in Haskell

   - make a low level primError that takes a utf8 string

   - get rid of noMatch and noDefault primitives

+* Fix bug with negative literal patterns

\ No newline at end of file

--- a/lib/AllOfLib.hs

+++ b/lib/AllOfLib.hs

@@ -53,6 +53,7 @@

 import Data.Ratio_Type

 import Data.Real

 import Data.RealFloat

+import Data.RealFrac

 import Data.Records

 import Data.Semigroup

 import Data.STRef

--- a/lib/Data/Double.hs

+++ b/lib/Data/Double.hs

@@ -17,6 +17,7 @@

 import Data.Ratio

 import Data.Real

 import Data.RealFloat

+import Data.RealFrac

 import Data.Num

 import Data.Word

 import Text.Read

@@ -74,6 +75,9 @@

                | otherwise =

     case decodeFloat x of

       (m, e) -> toRational m * 2^^e

+

+instance RealFrac Double where

+  properFraction _ = error "Double.properFraction not implemented"

 instance Floating Double where

   pi     = 3.141592653589793

--- a/lib/Data/Real.hs

+++ b/lib/Data/Real.hs

@@ -2,9 +2,10 @@

 import Prelude()              -- do not import Prelude

 import Primitives

 import Data.Fractional

+import Data.Num

 import Data.Ratio_Type

-class Real a where

+class Num a => Real a where

   toRational :: a -> Rational

 realToFrac :: forall a b . (Real a, Fractional b) => a -> b

--- /dev/null

+++ b/lib/Data/RealFrac.hs

@@ -1,0 +1,30 @@

+module Data.RealFrac(module Data.RealFrac) where

+import Prelude()

+import Primitives

+import Data.Ord

+import Data.Fractional

+import Data.Integral

+import Data.Num

+import Data.Real

+

+class  (Ord a, Real a, Fractional a) => RealFrac a  where

+  properFraction :: (Integral b) => a -> (b,a)

+  truncate       :: (Integral b) => a -> b

+  round          :: (Integral b) => a -> b

+  ceiling        :: (Integral b) => a -> b

+  floor          :: (Integral b) => a -> b

+

+  truncate x     =  m  where (m,_) = properFraction x

+  

+  round x        =  let (n,r) = properFraction x

+                        m     = if r < 0 then n - 1 else n + 1

+                        s     = signum (abs r - 0.5)

+                    in if s < 0 then n

+                       else if s > 0 then m

+                       else if even n then n else m

+

+  ceiling x      =  if r > 0 then n + 1 else n

+                      where (n,r) = properFraction x

+

+  floor x        =  if r < 0 then n - 1 else n

+                      where (n,r) = properFraction x

--- a/lib/Prelude.hs

+++ b/lib/Prelude.hs

@@ -27,6 +27,7 @@

   module Data.Ratio,

   module Data.Real,

   module Data.RealFloat,

+  module Data.RealFrac,

   module Data.Records,

   module Data.Semigroup,

   module Data.Tuple,

@@ -35,6 +36,7 @@

   module Text.Read,

   module Text.Show,

   module Text.String,

+  Float,

   usingMhs, _wordSize, _isWindows,

   ) where

 import Prelude()              -- do not import Prelude

@@ -64,6 +66,7 @@

 import Data.Ratio(Rational)

 import Data.Real(Real(..), realToFrac)

 import Data.RealFloat(RealFloat(..))

+import Data.RealFrac(RealFrac(..))

 import Data.Records  -- XXX redo this somehow

 import Data.Semigroup(Semigroup(..))

 import Data.Tuple(()(..), fst, snd)

@@ -79,3 +82,5 @@

 -- So we can detect mhs vs ghc

 usingMhs :: Bool

 usingMhs = True

+

+type Float = Double

--- a/src/MicroHs/Expr.hs

+++ b/src/MicroHs/Expr.hs

@@ -229,6 +229,7 @@

     EViewPat _ p -> patVars p

     ECon _ -> []

     EUpdate _ fs -> concatMap field fs

+    ENegApp _ -> []

     _ -> error $ "patVars " ++ showExpr apat

   where add i is | isConIdent i || isDummyIdent i = is

                  | otherwise = i : is

--- a/src/MicroHs/TypeCheck.hs

+++ b/src/MicroHs/TypeCheck.hs

@@ -1620,6 +1620,7 @@

     EViewPat e p -> EViewPat e <$> dsEFields p

     ECon _ -> return apat

     EUpdate c fs -> EUpdate c . concat <$> mapM (dsEField c) fs

+    ENegApp _ -> return apat

     _ -> error $ "dsEFields " ++ show apat

 -- XXX could be better

@@ -1895,7 +1896,7 @@

                (p, t) <- tLookupV i

                case t of

                  EUVar r -> tSetRefType loc r ext

-                 _ -> impossible

+                 _ -> impossibleShow t

                return ([], [], p)

     EOper e ies -> do e' <- tcOper e ies; tcPat mt e'

-- 

⑨