Helpers.hs

{-# OPTIONS_GHC -fno-warn-orphans #-}
-- |Shared version checks, arbitrary instances and value-comparison helpers for @QuantLib.Spec.*@.
module QuantLib.Spec.Helpers (
    ValidDay(..)
  , InvalidDay(..)
  , areClose
  , closePrec
  , listClose
  , listCloseRel
  , binomialsClose
  , quantLibAtMost143
  , unsupportedQuantLib144
  ) where

import Data.Time.Calendar
import Data.Char(isDigit)
import Data.List(delete)
import Text.Read(readMaybe)

import Test.QuickCheck(elements, Arbitrary(arbitrary))

import QuantLib.Time.Date(minDate, maxDate)
import QuantLib.Time.Schedule(Frequency(..))
import qualified QuantLib.Context as Context

quantLibAtMost143 :: Bool
quantLibAtMost143 = case break (== '.') Context.version of
  (major, '.':rest) -> case (readMaybe major, readMaybe (takeWhile isDigit rest)) of
    (Just major', Just minor') -> (major', minor') <= (1 :: Int, 43 :: Int)
    _ -> False
  _ -> False

unsupportedQuantLib144 :: String -> Context.Error -> Bool
unsupportedQuantLib144 name (Context.UnsupportedQuantLibVersion call required linked) =
  call == name && required == "1.44" && linked == Context.version
unsupportedQuantLib144 _ _ = False

instance Arbitrary Frequency where
  arbitrary = elements $ OtherFrequency `delete` [minBound .. ]

newtype ValidDay = ValidDay {validDay::Day} deriving (Show, Eq)
newtype InvalidDay = InvalidDay Day deriving (Show, Eq)
instance Arbitrary ValidDay where
  arbitrary = do
    d <- elements [toModifiedJulianDay minDate .. toModifiedJulianDay maxDate]
    return $ ValidDay (ModifiedJulianDay d)

instance Arbitrary InvalidDay where
  arbitrary = do
    d <- elements $ [minD-500 .. minD-1] ++ [maxD+1 .. maxD+500]
    return $ InvalidDay (ModifiedJulianDay d)
    where minD = toModifiedJulianDay minDate
          maxD = toModifiedJulianDay maxDate

-- literal translation of close from ql/math/comparison.hpp
areClose :: Double -> Double -> Bool
areClose x1 x2 = x1 == x2
            || x1 * x2 == 0 && diff < Context.epsilon * Context.epsilon
            || diff <= Context.epsilon * abs x1 && diff <= Context.epsilon * abs x2
            where diff = abs(x1 - x2)

closePrec :: Double -> Double -> Double -> Bool
closePrec r p x = abs (x - r) < p

listClose :: (a -> Double) -> [Double] -> Double -> [a] -> Bool
listClose f x1 e x2 = (length x1 == length x2) && all (\(x, y) -> abs(x - f y) < e) (zip x1 x2)

-- |Like 'listClose', but the tolerance is relative to each expected value
-- rather than a fixed absolute epsilon -- for tables whose entries span more
-- than an order of magnitude (e.g. CVA corrections from 0.24bp to 32bp).
listCloseRel :: (a -> Double) -> [Double] -> Double -> [a] -> Bool
listCloseRel f x1 e x2 = (length x1 == length x2) && all (\(x, y) -> abs(x - f y) < e * abs x) (zip x1 x2)

-- |row-wise 'listClose' at 1.0e-6, for tables of per-engine results (e.g. the
-- binomial-tree grid in the equity option example)
binomialsClose :: [[Double]] -> [[Double]] -> Bool
binomialsClose expected actual =
  length expected == length actual
    && and (zipWith (\e a -> listClose id e 1.0e-6 a) expected actual)