never executed always true always false

    1 module QuantLib.Internal
    2   (
    3     Day -- reexport for simplicity
    4   , minDate
    5   , maxDate
    6 
    7   -- marshalling helpers
    8   , prePtr
    9   , preErrorCheck
   10   , errorCheck
   11 
   12   , fromMaybeBool
   13   , toMaybeBool
   14   , peekDynString
   15   , peekEnum
   16   , peekDouble
   17   , preEnum
   18   , preNum
   19   , preArray
   20   , withEnumArray
   21   , withIntArray
   22   , withBoolArray
   23   , withDoubleArray
   24   , withNonEmptyDoubleArray
   25   , withDoubleArrayRaw
   26   , withBoolArrayRaw
   27   , withDayPtr
   28   , withStringArray
   29   , peekCStringArray
   30   , fromEnumQuantity
   31   , toEnumQuantity
   32   , fromEnumDouble
   33   , toEnumDouble
   34   , fromEnumC
   35   , toEnumC
   36 
   37   , withDay
   38   , toDay
   39   , withMaybeDay
   40   , fromMaybeInt
   41   , toMaybeDay
   42   , peekDayArray
   43   , peekBoolArray
   44   , withDayArray
   45   , peekDoubleArray
   46   , peekDoubleVector
   47 
   48   , toSerial
   49   , fromSerial
   50   , qlSavedSettings
   51   , qlFreeSavedSettings
   52   , fromMaybeDouble
   53   , fromMaybeEnum
   54   , fromMaybeEnumQuantity
   55   , peekIntArray
   56   , peekIntArray'
   57   , peekUIntArray
   58   , peekWord
   59   , peekStructArray
   60   , peekPtrArray
   61   , Matrix(..)
   62   , realMatrix
   63   , objectMatrix
   64   , qlNullInteger
   65   , qlFreeAdditionalResults
   66 
   67   , uncurryNested
   68   , zipWith6
   69   )
   70 where
   71 
   72 import Foreign.C.Types(CUInt(..), CInt(..), CDouble(..))
   73 import Foreign.C.String(CString, peekCString, withCString)
   74 import Foreign.Ptr(Ptr, nullPtr, castPtr)
   75 import Foreign.ForeignPtr(FinalizerPtr, newForeignPtr)
   76 import Foreign.Marshal.Array(peekArray, withArray)
   77 import Foreign.Marshal.Utils(with, toBool, fromBool, withMany)
   78 import Foreign.Storable(peek, Storable)
   79 import Foreign.Marshal.Alloc(alloca)
   80 
   81 import Control.Exception(throwIO)
   82 import Control.Monad(when)
   83 import Data.Time.Calendar(Day(ModifiedJulianDay), toModifiedJulianDay, fromGregorian)
   84 import Data.List.NonEmpty(NonEmpty, toList)
   85 
   86 import Data.Vector.Storable(Vector, unsafeFromForeignPtr0)
   87 
   88 import QuantLib.Type(Error(DateConversion, CPlusPlusException))
   89 
   90 errorCheck :: Ptr CString -> IO ()
   91 errorCheck p = do
   92   a <- peek p
   93   when
   94     (a /= nullPtr)
   95     ((peekCString a <* qlFreeString a) >>= throwIO . CPlusPlusException)
   96 
   97 -- like alloca but initializes the allocated pointer with zero
   98 preErrorCheck :: (Ptr (Ptr a) -> IO b) -> IO b
   99 preErrorCheck = with nullPtr
  100 
  101 fromMaybeBool :: Maybe Bool -> CInt
  102 fromMaybeBool = maybe (-1) fromBool
  103 
  104 foreign import ccall safe "ql.h qlNullInteger" qlNullInteger :: CInt
  105 foreign import ccall safe "ql.h qlNullReal" qlNullReal :: CDouble
  106 
  107 fromMaybeInt :: (Integral a, Integral b) => Maybe a -> b
  108 fromMaybeInt = maybe (fromIntegral qlNullInteger) fromIntegral
  109 
  110 fromMaybeDouble :: Maybe Double -> CDouble
  111 fromMaybeDouble = maybe qlNullReal realToFrac
  112 
  113 -- |Marshals a Maybe of a plain by-value C++ enum whose lowest member maps to 0
  114 -- (true of every by-value enum bound so far) as a C int, using -1 as the
  115 -- ext::nullopt sentinel -- mirrors fromMaybeBool's convention.
  116 fromMaybeEnum :: Enum a => Maybe a -> CInt
  117 fromMaybeEnum = maybe (-1) (fromIntegral . fromEnum)
  118 
  119 -- |'Nothing' emits the enum's -1 sentinel (same convention as 'fromMaybeEnum'), paired with a
  120 -- placeholder quantity of 0 -- for enums like 'TimeUnit' that start at 0 and can't self-sentinel.
  121 fromMaybeEnumQuantity :: Enum a => Maybe (Word, a) -> (CInt, CInt)
  122 fromMaybeEnumQuantity = maybe (0, -1) fromEnumQuantity
  123 
  124 toMaybeBool :: CInt -> Maybe Bool
  125 toMaybeBool x = if x == -1 then Nothing else Just $ toBool x
  126 
  127 peekDynString :: CString -> IO String
  128 peekDynString x = peekCString x <* qlFreeString x
  129 
  130 peekEnum :: (Enum a) => Ptr CInt -> IO a
  131 peekEnum x = toEnum . fromIntegral <$> peek x
  132 
  133 peekDouble :: Ptr CDouble -> IO Double
  134 peekDouble x = realToFrac <$> peek x
  135 
  136 peekWord :: Ptr CUInt -> IO Word
  137 peekWord x = fromIntegral <$> peek x
  138 
  139 -- initialize pointer to a enum with a valid value before passing it to the function
  140 preEnum :: (Storable a, Bounded a) => (Ptr a -> IO b) -> IO b
  141 preEnum = with minBound
  142 
  143 preNum :: (Storable a, Num a) => (Ptr a -> IO b) -> IO b
  144 preNum = with 0
  145 
  146 foreign import ccall safe "ql.h qlFreeString" qlFreeString :: CString -> IO ()
  147 foreign import ccall safe "ql.h qlFreeInts" qlFreeInts :: Ptr CInt -> IO ()
  148 foreign import ccall safe "ql.h qlFreeUInts" qlFreeUInts :: Ptr CUInt -> IO ()
  149 foreign import ccall safe "ql.h qlFreeDoubles" qlFreeDoubles :: Ptr CDouble -> IO ()
  150 foreign import ccall safe "ql.h &qlFreeDoubles" qlFreeDoublesFin :: FinalizerPtr CDouble
  151 foreign import ccall safe "ql.h qlFreePointerArray" qlFreePointerArray :: Ptr (Ptr ()) -> IO ()
  152 foreign import ccall safe "ql.h qlFreeAdditionalResults" qlFreeAdditionalResults :: CUInt -> Ptr () -> IO ()
  153 foreign import ccall safe "ql.h qlFreeStringArray" qlFreeStringArray :: CUInt -> Ptr CString -> IO ()
  154 foreign import ccall safe "ql.h qlSavedSettings" qlSavedSettings :: IO (Ptr ())
  155 foreign import ccall safe "ql.h qlFreeSavedSettings" qlFreeSavedSettings :: Ptr () -> IO ()
  156 
  157 withLArray :: (Storable b) => (a -> b) -> [a] -> ((CUInt, Ptr b) -> IO c) -> IO c
  158 withLArray c x f = withArray (map c x) (\px -> f (fromIntegral $ length x, px))
  159 
  160 withEnumArray :: (Enum a) => [a] -> ((CUInt, Ptr CInt) -> IO b) -> IO b
  161 withEnumArray = withLArray (fromIntegral . fromEnum)
  162 
  163 withIntArray :: (Integral a, Num n, Storable n) => [a] -> ((CUInt, Ptr n) -> IO b) -> IO b
  164 withIntArray = withLArray fromIntegral
  165 
  166 withBoolArray :: [Bool] -> ((CUInt, Ptr CInt) -> IO b) -> IO b
  167 withBoolArray = withLArray fromBool
  168 
  169 withDoubleArray :: [Double] -> ((CUInt, Ptr CDouble) -> IO b) -> IO b
  170 withDoubleArray = withLArray realToFrac
  171 
  172 withNonEmptyDoubleArray :: NonEmpty Double -> ((CUInt, Ptr CDouble) -> IO b) -> IO b
  173 withNonEmptyDoubleArray x = withLArray realToFrac (toList x)
  174 
  175 withDoubleArrayRaw :: [Double] -> (Ptr CDouble -> IO b) -> IO b
  176 withDoubleArrayRaw x = withArray (map realToFrac x)
  177 
  178 withBoolArrayRaw :: [Bool] -> (Ptr CInt -> IO b) -> IO b
  179 withBoolArrayRaw x = withArray (map fromBool x)
  180 
  181 withDayArray :: [Day] -> ((CUInt, Ptr CInt) -> IO b) -> IO b
  182 withDayArray x f = mapM toSerial x >>= (`withArray` (\px -> f (fromIntegral $ length x, px)))
  183 
  184 withDayPtr :: [Day] -> (Ptr CInt -> IO a) -> IO a
  185 withDayPtr x f = mapM toSerial x >>= (`withArray` f)
  186 
  187 -- |An array of plain C strings, for a function taking a @std::vector<std::string>@-shaped
  188 -- argument as a flat @(count, char**)@ pair (the input-side counterpart of 'peekCStringArray'
  189 -- below) -- first needed for @SecondaryCosts@' string keys (@QuantLib.Instrument.Energy@).
  190 withStringArray :: [String] -> ((CUInt, Ptr CString) -> IO b) -> IO b
  191 withStringArray xs f = withMany withCString xs (\ps -> withArray ps (\p -> f (fromIntegral (length xs), p)))
  192 
  193 prePtr :: (Storable a) => (Ptr a -> IO b) -> IO b
  194 prePtr = alloca
  195 
  196 preArray :: ((Ptr CUInt, Ptr (Ptr a)) -> IO b) -> IO b
  197 preArray f = with 0 $
  198   \x -> with nullPtr $
  199     \y -> f (x, y)
  200 
  201 peekIntArray' :: (CInt -> b) -> Ptr CUInt -> Ptr (Ptr CInt) -> IO [b]
  202 peekIntArray' f pl pp = do
  203   l <- peek pl
  204   p <- peek pp
  205   map f <$> peekArray (fromIntegral l) p <* qlFreeInts p
  206 
  207 peekUIntArray :: Ptr CUInt -> Ptr (Ptr CUInt) -> IO [Word]
  208 peekUIntArray pl pp = do
  209   l <- peek pl
  210   p <- peek pp
  211   map fromIntegral <$> peekArray (fromIntegral l) p <* qlFreeUInts p
  212 
  213 peekIntArray :: Ptr CUInt -> Ptr (Ptr CInt) -> IO [Int]
  214 peekIntArray = peekIntArray' fromIntegral
  215 
  216 -- |An array of freshly heap-allocated (@DUP@'d) C strings -- the output-side counterpart of
  217 -- 'withStringArray'. Each element is read via 'peekCString' and the whole array (including every
  218 -- individual string) is then released via 'qlFreeStringArray' in one call, mirroring
  219 -- 'peekDoubleArray'\/'peekIntArray'\''s read-then-free shape.
  220 peekCStringArray :: Ptr CUInt -> Ptr (Ptr CString) -> IO [String]
  221 peekCStringArray pl pp = do
  222   l <- peek pl
  223   p <- peek pp
  224   raws <- peekArray (fromIntegral l) p
  225   strs <- mapM peekCString raws
  226   strs <$ qlFreeStringArray l p
  227 
  228 peekBoolArray :: Ptr CUInt -> Ptr (Ptr CInt) -> IO [Bool]
  229 peekBoolArray = peekIntArray' toBool
  230 
  231 peekDayArray :: Ptr CUInt -> Ptr (Ptr CInt) -> IO [Day]
  232 peekDayArray = peekIntArray' fromSerial
  233 
  234 peekDoubleArray :: Ptr CUInt -> Ptr (Ptr CDouble) -> IO [Double]
  235 peekDoubleArray pl pp = do
  236   l <- peek pl
  237   p <- peek pp
  238   map realToFrac <$> peekArray (fromIntegral l) p <* qlFreeDoubles p
  239 
  240 peekDoubleVector :: Ptr CUInt -> Ptr (Ptr CDouble) -> IO (Vector CDouble)
  241 peekDoubleVector pl pp = unsafeFromForeignPtr0 <$> (peek pp >>= newForeignPtr qlFreeDoublesFin) <*> (fromIntegral <$> peek pl)
  242 
  243 -- |Like 'peekIntArray'\''/'peekDoubleArray', but for an array of a C struct rather than a C
  244 -- primitive: reads the length and pointer out-params, walks the array via 'peekArray' (so the
  245 -- element type just needs a 'Storable' instance -- e.g. one built from c2hs @{#get#}@/@{#sizeof#}@
  246 -- hooks), converts every element via @convert@, /then/ hands the whole array to @freeFn@ to
  247 -- release. The conversion must run before the free -- unlike 'peekIntArray'\''/'peekDoubleArray',
  248 -- whose elements are self-contained primitives, a struct element read here may itself own
  249 -- further heap buffers (e.g. a @char*@/@double*@ field) that @convert@ still needs to dereference
  250 -- (via 'peekCString'/'peekArray' etc.); freeing first would leave it reading already-freed
  251 -- memory. @freeFn@ takes the element count because some frees need it (e.g.
  252 -- 'qlFreeAdditionalResults'); one that doesn't can ignore it.
  253 peekStructArray :: Storable a => (a -> IO b) -> (CUInt -> Ptr a -> IO ()) -> Ptr CUInt -> Ptr (Ptr a) -> IO [b]
  254 peekStructArray convert freeFn pl pp = do
  255   l <- peek pl
  256   p <- peek pp
  257   raws <- peekArray (fromIntegral l) p
  258   results <- mapM convert raws
  259   results <$ freeFn l p
  260 
  261 -- |Like 'peekStructArray' but for a @T**@ array of C++-owned pointers to live objects: peeks the
  262 -- length/pointer out-params, converts each raw pointer to a live Haskell value via @peekOne@
  263 -- (installing that value's own finalizer over the pointee), then frees only the array spine via
  264 -- 'qlFreePointerArray' -- not the pointees, whose lifetime @peekOne@ has now taken over.
  265 peekPtrArray :: (Ptr a -> IO b) -> Ptr CUInt -> Ptr (Ptr (Ptr a)) -> IO [b]
  266 peekPtrArray peekOne pl pp = do
  267   l <- peek pl
  268   p <- peek pp
  269   ptrs <- peekArray (fromIntegral l) p
  270   xs <- mapM peekOne ptrs
  271   xs <$ qlFreePointerArray (castPtr p)
  272 
  273 fromEnumQuantity :: (Enum a, Integral b, Integral c) => (b, a) -> (CInt, c)
  274 fromEnumQuantity (x, u) = (fromIntegral x, fromIntegral $ fromEnum u)
  275 
  276 toEnumQuantity :: (Enum a, Integral b, Integral c) => (CInt, c) -> (b, a)
  277 toEnumQuantity (x, u) = (fromIntegral x, toEnum $ fromIntegral u)
  278 
  279 fromEnumDouble :: (Enum a, Integral c) => (Double, a) -> (CDouble, c)
  280 fromEnumDouble (x, u) = (realToFrac x, fromIntegral $ fromEnum u)
  281 
  282 toEnumDouble :: (Enum a, Integral c) => (CDouble, c) -> (Double, a)
  283 toEnumDouble (x, u) = (realToFrac x, toEnum $ fromIntegral u)
  284 
  285 foreign import ccall safe "ql.h qlMinYear" qlMinYear :: CInt
  286 foreign import ccall safe "ql.h qlMinMonth" qlMinMonth :: CInt
  287 foreign import ccall safe "ql.h qlMinDay" qlMinDay :: CInt
  288 foreign import ccall safe "ql.h qlMinDateSerialNumber" qlMinDateSerialNumber :: CInt
  289 foreign import ccall safe "ql.h qlMaxDateSerialNumber" qlMaxDateSerialNumber :: CInt
  290 
  291 -- |Julian day of the QuantLib zero date
  292 qlStart :: CInt
  293 qlStart = minDateJulianDays - qlMinDateSerialNumber
  294   where minDateJulianDays = toModifiedJulianDay' $ fromGregorian (fromIntegral qlMinYear) (fromIntegral qlMinMonth) (fromIntegral qlMinDay)
  295 
  296 toModifiedJulianDay' :: Day -> CInt
  297 toModifiedJulianDay' = fromIntegral . toModifiedJulianDay
  298 
  299 fromSerial :: CInt -> Day
  300 fromSerial x = ModifiedJulianDay $ fromIntegral (x + qlStart)
  301 
  302 dayIsValid :: Day -> Bool
  303 dayIsValid x = s >= qlMinDateSerialNumber && s <= qlMaxDateSerialNumber
  304   where s = toModifiedJulianDay' x - qlStart
  305 
  306 toSerial :: Day -> IO CInt
  307 toSerial x | dayIsValid x = return $ toModifiedJulianDay' x - qlStart
  308            | otherwise = throwIO $ DateConversion x
  309 
  310 withDay :: Day -> (CInt -> IO a) -> IO a
  311 withDay x f = toSerial x >>= f
  312 
  313 toDay :: CInt -> Day
  314 toDay = fromSerial
  315 
  316 withMaybeDay :: Maybe Day -> (CInt -> IO a) -> IO a
  317 withMaybeDay x f = maybe (f 0) (`withDay` f) x
  318 
  319 -- |Unlike the -1 sentinel used by 'fromMaybeBool'/'fromMaybeEnum'/'toMaybeBool', the
  320 -- absent-date sentinel is 0: QuantLib serial 0 is not a representable date (serials
  321 -- start at 'qlMinDateSerialNumber'), so it is free to mean "no date". This matches
  322 -- 'withMaybeDay', which passes 0 in the other direction.
  323 toMaybeDay :: CInt -> Maybe Day
  324 toMaybeDay 0 = Nothing
  325 toMaybeDay x = Just $ fromSerial x
  326 
  327 -- |earliest allowed date in QuantLib
  328 minDate :: Day
  329 minDate = fromSerial qlMinDateSerialNumber
  330 
  331 -- |latest date allowed in QuantLib
  332 maxDate :: Day
  333 maxDate = fromSerial qlMaxDateSerialNumber
  334 
  335 data Matrix a = Matrix {matrixRows::Word, matrixColumns::Word, matrixData::[a]}
  336   deriving (Eq, Show)
  337 
  338 -- |'objectMatrix' specialised to 'Double'. Kept as a separate name for callers that
  339 -- need the element type pinned; the check and construction are identical.
  340 realMatrix :: Word -> Word -> [Double] -> Either String (Matrix Double)
  341 realMatrix = objectMatrix
  342 
  343 objectMatrix :: Word -> Word -> [a] -> Either String (Matrix a)
  344 objectMatrix rows cols d
  345   | rows * cols == fromIntegral (length d) = Right $ Matrix rows cols d
  346   | otherwise = Left $ "Data length " ++ show (length d)
  347       ++ " does not match dimensions " ++ show rows ++ "x" ++ show cols
  348 
  349 -- just a generic implementation to help when it's difficult to have Enum declaration due to complex module deps
  350 fromEnumC :: (Enum a, Integral b) => a -> b
  351 fromEnumC = fromIntegral . fromEnum
  352 
  353 -- output-direction counterpart to 'fromEnumC', for a {#fun#} returning a bare enum value
  354 -- (not through a pointer out-param, see 'peekEnum' for that case) across the same module-dep boundary
  355 toEnumC :: (Enum a, Integral b) => b -> a
  356 toEnumC = toEnum . fromIntegral
  357 
  358 uncurryNested :: (a -> b -> c -> d) -> (a, (b, c)) -> d
  359 uncurryNested f (x, (y, z)) = f x y z
  360 
  361 -- |'Prelude' only goes up to 'zipWith3'; this fills the gap for unpacking a C-side
  362 -- structure-of-parallel-arrays result into one Haskell record/tuple per element.
  363 zipWith6 :: (a -> b -> c -> d -> e -> f -> g) -> [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [g]
  364 zipWith6 f (a:as) (b:bs) (c:cs) (d:ds) (e:es) (g:gs) = f a b c d e g : zipWith6 f as bs cs ds es gs
  365 zipWith6 _ _ _ _ _ _ _ = []
  366 
  367 -- vim: set ff=unix ts=8 sts=2 sw=2 et: