altfloat-0.3: examples/fenv-impure.hs

{-
 - Copyright (C) 2009-2010 Nick Bowler.
 -
 - License BSD2:  2-clause BSD license.  See LICENSE for full terms.
 - This is free software: you are free to change and redistribute it.
 - There is NO WARRANTY, to the extent permitted by law.
 -}

-- | Demonstration of why "Data.Floating.Environment" still doesn't give us
-- referential transparency if the user is not careful.  It is important that
-- all non-FEnv floating point expressions are forced *before* they are used
-- in a FEnv expression.
{-# LANGUAGE NoImplicitPrelude #-}
module Main where

import Data.Floating.Prelude
import Data.Floating.Environment

-- | The largest integral value representable in an IEEE double with no
-- larger non-integral value.
bigDouble :: Double
bigDouble = 4503599627370496

-- | Here be dragons!
broken :: IO ()
broken = let
        -- x and y are values formed by passing the same inputs to the same
        -- function, (+).  Referential transparency says that x and y are
        -- interchangable...
        (x, y) = (bigDouble + 0.5, bigDouble + 0.5)
    in do
        putStrLn $ "x = " ++ show x
        fenvEval (withRoundingMode Upward (seq y <$> 0)) >>= print
        putStrLn $ "y = " ++ show y
        print (x == y)
        --- ...but now x and y are different.

-- | The problem with the 'broken' function is that the argument to 'fmap',
-- namely @seq y@, forces a pure floating point expression.  The easiest way
-- to avoid these kind of problems is to only use such expressions as the
-- argument to 'pure', which will ensure that they are forced before 'fenvEval'
-- is called.  The above function could be rewritten as follows.
notBroken :: IO ()
notBroken = let
        -- x and y are values formed by passing the same inputs to the same
        -- function, (+).  Referential transparency says that x and y are
        -- interchangable...
        (x, y) = (bigDouble + 0.5, bigDouble + 0.5)
    in do
        putStrLn $ "x = " ++ show x
        fenvEval (withRoundingMode Upward (seq <$> pure y <*> 0)) >>= print
        putStrLn $ "y = " ++ show y
        print (x == y)
        -- ... and indeed they seem to be!

main :: IO ()
main = do
    putStrLn "Non-broken behaviour:"
    notBroken
    putStrLn "\nBroken behaviour:"
    broken