Finish porting the old calls.

As you can see, they're still quite incomplete. Patches welcome.

Main.hs

@@ -35,14 +35,6 @@ import Masque.Monte
 import Masque.Objects
 import Masque.Vats
 
--- -- | Lenses
--- 
--- _DoubleObj :: Prism' Obj Double
--- _DoubleObj = prism' DoubleObj $ \o -> case o of
---     DoubleObj d -> Just d
---     IntObj i    -> Just $ fromIntegral i
---     _           -> Nothing
--- 
 -- -- | Lenses on other data types
 -- -- These are destined for various upstreams at some point.
 -- 
@@ -82,40 +74,6 @@ import Masque.Vats
 --     , "traceln"
 --     ]
 -- 
--- callDouble :: Double -> String -> [Obj] -> Maybe Obj
--- callDouble d "abs" [] = Just . DoubleObj $ abs d
--- callDouble d "add" [preview _DoubleObj -> Just d'] = Just . DoubleObj $ d + d'
--- callDouble d "multiply" [preview _DoubleObj -> Just d'] = Just . DoubleObj $ d * d'
--- callDouble d "negate" [] = Just . DoubleObj $ negate d
--- callDouble d "op__cmp" [preview _DoubleObj -> Just d'] = Just $ cmp d d'
--- callDouble d "sqrt" [] = Just . DoubleObj $ sqrt d
--- callDouble d "subtract" [preview _DoubleObj -> Just d'] = Just . DoubleObj $ d - d'
--- callDouble _ _ _ = Nothing
--- 
--- callInt :: Integer -> String -> [Obj] -> Maybe Obj
--- callInt i "op__cmp" [DoubleObj d] = Just $ cmp (realToFrac i) d
--- callInt i "op__cmp" [IntObj j] = Just $ cmp i j
--- callInt i "aboveZero" [] = Just . BoolObj $ i > 0
--- callInt i "add" [IntObj j] = Just . IntObj $ i + j
--- callInt i "and" [IntObj j] = Just . IntObj $ i .&. j
--- callInt i "atLeastZero" [] = Just . BoolObj $ i >= 0
--- callInt i "atMostZero" [] = Just . BoolObj $ i <= 0
--- callInt i "approxDivide" [DoubleObj d] = Just . DoubleObj $ realToFrac i / d
--- callInt i "belowZero" [] = Just . BoolObj $ i < 0
--- callInt i "floorDivide" [IntObj j] = Just . IntObj $ i `div` j
--- callInt i "isZero" [] = Just . BoolObj $ i == 0
--- callInt i "multiply" [DoubleObj d] = Just . DoubleObj $ d * realToFrac i
--- callInt i "multiply" [IntObj j] = Just . IntObj $ i * j
--- callInt i "pow" [IntObj j] = Just . IntObj $ i ^ j
--- callInt i "subtract" [IntObj j] = Just . IntObj $ i - j
--- callInt _ _ _ = Nothing
--- 
--- call :: Obj -> String -> [Obj] -> Monte Obj
--- call o@(DoubleObj d) verb args =
---     maybe (left (Refused o verb args S.empty)) return $ callDouble d verb args
--- call o@(IntObj i) verb args =
---     maybe (left (Refused o verb args S.empty)) return $ callInt i verb args
--- 
 -- call (EjectorObj u) "run" [obj] = left $ Ejecting u obj
 -- 
 -- call (RefObj ref) verb args = do

Masque/Eval.hs

@@ -22,6 +22,8 @@ import Masque.Ejectors
 import Masque.Monte
 import Masque.Objects
 import Masque.Objects.Bool
+import Masque.Objects.Double
+import Masque.Objects.Int
 import Masque.Objects.Str
 
 -- | Smart constructor for a final binding; perform the guarding operation as
@@ -186,6 +188,8 @@ eval (TryExpr expr catchPatt catchBody) = catchError try recover
 -- | Deliver a message immediately to an object.
 call :: Obj -> String -> [Obj] -> [(Obj, Obj)] -> Monte Obj
 call obj verb args namedArgs = case obj of
-    BoolObj b -> callBool b verb args namedArgs
-    StrObj s  -> callStr s verb args namedArgs
-    _         -> error "Not written yet"
+    BoolObj b   -> callBool b verb args namedArgs
+    DoubleObj d -> callDouble d verb args namedArgs
+    IntObj i    -> callInt i verb args namedArgs
+    StrObj s    -> callStr s verb args namedArgs
+    _           -> error "Not written yet"

Masque/Monte.hs

@@ -61,25 +61,36 @@ runPureMonte action = runMonte action (Env M.empty :| [])
 refuse :: Monte a
 refuse = left Refused
 
+-- | "It's the wrong type, Gromit!" ~ Wallace, implementing Monte
+wrongType :: Monte a
+wrongType = left WrongType
+
 unwrapBool :: Obj -> Monte Bool
 unwrapBool (BoolObj b) = return b
-unwrapBool _ = left WrongType
+unwrapBool _ = wrongType
 
 unwrapChar :: Obj -> Monte Char
 unwrapChar (CharObj c) = return c
-unwrapChar _ = left WrongType
+unwrapChar _ = wrongType
 
 unwrapDouble :: Obj -> Monte Double
 unwrapDouble (DoubleObj d) = return d
-unwrapDouble _ = left WrongType
+unwrapDouble _ = wrongType
+
+-- | Like `unwrapDouble`, but also promotes Ints to Doubles. Useful for doing
+--   some sorts of maths.
+coerceDouble :: Obj -> Monte Double
+coerceDouble (DoubleObj d) = return d
+coerceDouble (IntObj i) = return $ fromIntegral i
+coerceDouble _ = wrongType
 
 unwrapInt :: Obj -> Monte Integer
 unwrapInt (IntObj i) = return i
-unwrapInt _ = left WrongType
+unwrapInt _ = wrongType
 
 unwrapStr :: Obj -> Monte String
 unwrapStr (StrObj s) = return s
-unwrapStr _ = left WrongType
+unwrapStr _ = wrongType
 
 -- | Wrap a Bool in a Monte object.
 wrapBool :: Bool -> Monte Obj
@@ -89,6 +100,10 @@ wrapBool = return . BoolObj
 wrapChar :: Char -> Monte Obj
 wrapChar = return . CharObj
 
+-- | Wrap a Double in a Monte object.
+wrapDouble :: Double -> Monte Obj
+wrapDouble = return . DoubleObj
+
 -- | Wrap an Int in a Monte object.
 wrapInt :: Integer -> Monte Obj
 wrapInt = return . IntObj

Masque/Objects/Double.hs

@@ -0,0 +1,37 @@
+module Masque.Objects.Double where
+
+import Masque.Monte
+import Masque.Objects
+
+ordering :: Ord a => a -> a -> Monte Obj
+ordering x y = wrapInt $ case x `compare` y of
+    LT -> -1
+    EQ -> 0
+    GT -> 1
+
+nan :: Monte Obj
+nan = wrapDouble $ 0 / 0
+
+-- | Pass a message to a Double.
+callDouble :: Double -> String -> [Obj] -> [(Obj, Obj)]-> Monte Obj
+-- Unary.
+callDouble d "abs" [] _ = wrapDouble $ abs d
+callDouble d "negate" [] _ = wrapDouble $ negate d
+callDouble d "sqrt" [] _ = wrapDouble $ sqrt d
+-- Binary.
+callDouble d "add" [obj] _ = do
+    x <- coerceDouble obj
+    wrapDouble $ d + x
+callDouble d "approxDivide" [obj] _ = do
+    x <- coerceDouble obj
+    wrapDouble $ d / x
+callDouble d "multiply" [obj] _ = do
+    x <- coerceDouble obj
+    wrapDouble $ d * x
+callDouble d "subtract" [obj] _ = do
+    x <- coerceDouble obj
+    wrapDouble $ d - x
+callDouble d "op__cmp" [obj] _ = do
+    x <- coerceDouble obj
+    if isNaN d || isNaN x then nan else ordering d x
+callDouble _ _ _ _ = refuse

Masque/Objects/Int.hs

@@ -0,0 +1,28 @@
+module Masque.Objects.Int where
+
+import Data.Bits
+
+import Masque.Monte
+import Masque.Objects
+
+-- XXX I don't have the gumption to clean this up right now
+callInt :: Integer -> String -> [Obj] -> [(Obj, Obj)] -> Monte Obj
+-- Unary
+-- Binary
+-- callInt i "op__cmp" [DoubleObj d] _ = Just $ cmp (realToFrac i) d
+-- callInt i "op__cmp" [IntObj j] _ = Just $ cmp i j
+callInt i "add" [IntObj j] _ = wrapInt $ i + j
+callInt i "and" [IntObj j] _ = wrapInt $ i .&. j
+callInt i "approxDivide" [DoubleObj d] _ = wrapDouble $ realToFrac i / d
+callInt i "floorDivide" [IntObj j] _ = wrapInt $ i `div` j
+callInt i "multiply" [DoubleObj d] _ = wrapDouble $ d * realToFrac i
+callInt i "multiply" [IntObj j] _ = wrapInt $ i * j
+callInt i "pow" [IntObj j] _ = wrapInt $ i ^ j
+callInt i "subtract" [IntObj j] _ = wrapInt $ i - j
+-- Comparison
+callInt i "aboveZero" [] _ = wrapBool $ i > 0
+callInt i "atLeastZero" [] _ = wrapBool $ i >= 0
+callInt i "atMostZero" [] _ = wrapBool $ i <= 0
+callInt i "belowZero" [] _ = wrapBool $ i < 0
+callInt i "isZero" [] _ = wrapBool $ i == 0
+callInt _ _ _ _ = refuse

masque.cabal

@@ -1,6 +1,3 @@
--- Initial masque.cabal generated by cabal init.  For further 
--- documentation, see http://haskell.org/cabal/users-guide/
-
 name:                masque
 version:             15.4.0.0
 -- synopsis:            
@@ -24,6 +21,8 @@ executable masque
                      , Masque.Eval
                      , Masque.Objects
                      , Masque.Objects.Bool
+                     , Masque.Objects.Double
+                     , Masque.Objects.Int
                      , Masque.Objects.Str
                      , Masque.Vats
   other-extensions:    DeriveDataTypeable,