hasquant-0.8.0.0: QuantLib/Internal/Common.chs

{-# LANGUAGE TemplateHaskell, StandaloneDeriving, ExistentialQuantification #-}
-- internal utilities to convert special enums: either complex ones or represented as QuantLib objects that I didn't want to expose so I represented them as ADTs
{-# OPTIONS_GHC -Wno-unused-top-binds #-}
module QuantLib.Internal.Common
  (
    qlInterpolation
  , qlInterpolation'
  , Approximation(..)
  , Interpolation(..)
  , Interpolation2D(..)
  , IterativeBootstrapOpts(..)
  , defaultIterativeBootstrapOpts

  , ExerciseType(..)
  , Exercise(..)
  , QlExercise
  , EuropeanExercise(..)
  , BermudanExercise(..)
  , QlEuropeanExercise
  , QlBermudanExercise
  , SwingExercise(..)
  , QlSwingExercise

  , OptionType(..)
  , PositionType(..)
  , BondPriceType(..)

  , StrikedPayoff(..)
  , PlainVanillaPayoff(..)
  , PercentageStrikePayoff(..)
  , QlPlainVanillaPayoff
  , QlPercentageStrikePayoff
  , QlStrikedTypePayoff
  , Payoff(..)
  , QlPayoff
  , BasketPayoff(..)
  , QlBasketPayoff
  , TypePayoff(..)
  , QlTypePayoff

  , CallabilityType(..)
  , Callability(..)
  , QlCallability

  , Claim(..)
  , QlClaim
  , withClaim

  , FittingMethod(..)
  , QlFittedBondDiscountCurveFittingMethod
  , withFittedBondDiscountCurveFittingMethod

  , FdmSchemeType(..)
  , FdmScheme(..)
  , QlFdmSchemeDesc
  , withFdmSchemeDesc

  , CPIInterpolationType(..)

  , StubIndexSelection(..)
  , withStubIndexSelection
  , OvernightObservation(..)
  , defaultOvernightObservation

  , Constraint(..)
  , QlConstraint
  , withConstraint
  , withMaybeConstraint
  , OptimizationMethod(..)
  , QlOptimizationMethod
  , withOptimizationMethod
  , withMaybeOptimizationMethod
  , EndCriteria(..)
  , QlEndCriteria
  , withEndCriteria
  , withMaybeEndCriteria

  , QlRounding
  , RoundingType(..)
  , Rounding(..)
  , withRounding
  , withMaybeRounding

  , withCallability
  , withCallabilityArray

  , QlLmVolatilityModel
  , LmVolatilityModel(..)
  , QlLmCorrelationModel
  , LmCorrelationModel(..)
  , withLmCorrelationModel
  , withLmVolatilityModel

  , TimeUnit(..)
  , BusinessDayConvention(..)

  , withEuropeanExercise
  , withSwingExercise
  , withBermudanExercise
  , withExercise
  , withPercentageStrikePayoff
  , withPlainVanillaPayoff
  , withStrikedPayoff
  , withTypePayoff
  , withBasketPayoff
  , withPayoff
  , withCustomPayoff
  , withCustomStrikedPayoff
  , withCustomBasketPayoff

  , strikedPayoff
  , percentageStrikePayoff
  , plainVanillaPayoff
  , swingExercise

  , CalibrationBasketType(..)

  , UnitOfMeasureType(..)
  , PaymentTermEventType(..)
  , PricingErrorLevel(..)
  , peekPricingErrorLevelArray
  , DeliverySchedule(..)
  , QuantityPeriodicity(..)

  , AdditionalResultType(..)
  , AdditionalResultVal(..)
  , RawResultPtr
  , RawResult(..)
  , convertResult
  , preAdditionalResults
  , peekAdditionalResults
  ) where
import Foreign.Ptr(Ptr, nullPtr, castPtr)
import Foreign.C.Types(CUInt, CInt, CDouble)
import Foreign.C.String(CString, peekCString)
import Foreign.Storable(Storable(..))
import Foreign.Marshal.Utils(withMany)
import Foreign.Marshal.Array(withArray, peekArray)
import Data.List.NonEmpty(NonEmpty, toList)

import QuantLib.Internal
import QuantLib.Internal.Type hiding(ptr)
import QuantLib.Internal.Syntax

#include "qlTypesC2HS.h"
#include "ql.h"

#include "qlEnumC2HS.h"
#include "qlEnumObjects.h"

-- |Every constructor parameter of QuantLib's curve-generic @IterativeBootstrap@.
-- The first three fields are 'Maybe' because 'Nothing' preserves QuantLib's
-- @Null\<Real\>()@ sentinel, which selects a suitable value for each curve pillar.
$(deriveOptionsRecord "IterativeBootstrapOpts" []
  [ ("ibAccuracy", [t|Maybe Double|], [|Nothing|])
  , ("ibMinValue", [t|Maybe Double|], [|Nothing|])
  , ("ibMaxValue", [t|Maybe Double|], [|Nothing|])
  , ("ibMaxAttempts", [t|Word|], [|1|])
  , ("ibMaxFactor", [t|Double|], [|2.0|])
  , ("ibMinFactor", [t|Double|], [|2.0|])
  , ("ibDontThrow", [t|Bool|], [|False|])
  , ("ibDontThrowSteps", [t|Word|], [|10|])
  , ("ibMaxEvaluations", [t|Word|], [|100|])
  ])

-- this enum is not special, just used in many places and was put here to avoid cyclic dependencies
{#enum TimeUnit{} deriving(Show, Eq, Read, Bounded)#}
-- moved from QuantLib.Time.Calendar, its "natural" home, for the same reason as TimeUnit above --
-- needed directly here for RebatedExercise's rebatePaymentConvention param. Like TimeUnit, every
-- cross-module use marshals through a manual fromEnumC/toEnumC/fromMaybeEnum function rather than
-- a bare c2hs backtick spec: a bare `` `BusinessDayConvention' `` needs the type's own module's
-- .chi already built, which this other-modules-listed module isn't guaranteed to have by the time
-- an early exposed-modules file (e.g. QuantLib.Time.Calendar itself) is processed.
{#enum BusinessDayConvention{} deriving(Show, Eq, Read)#}
{#enum ApproximationType{} add prefix="Approximation__" deriving(Show, Eq, Read)#}
{#enum InterpolationType{} add prefix="Interpolation" deriving(Show, Eq, Read)#}
-- 2-D interpolators for a BlackVarianceSurface. Unlike InterpolationType/ApproximationType
-- above (merged into the public Interpolation ADT by deriveCrossEnum), this enum is itself the
-- public type: setInterpolation on a surface is a member template over a default-constructed
-- interpolator, so there is no approximator to pair it with. Declared here rather than in
-- QuantLib.TermStructure.Volatility for the usual cross-module {#import#} ordering reason.
{#enum Interpolation2D{} deriving (Show, Eq, Read, Bounded)#}
{#enum ExerciseType{} add prefix = "ExerciseType" deriving (Show, Eq, Read)#}
{#enum OptionType{} deriving (Show, Eq, Read)#}
{#enum PositionType{} deriving (Show, Eq, Read)#}
{#enum BondPriceType{} deriving (Show, Eq, Read)#}
{#enum CallabilityType{} add prefix="Callability" deriving(Show, Eq, Read)#}
{#enum FdmSchemeType{} deriving(Show, Eq, Read)#}
{#enum RoundingType{} deriving (Show, Eq, Read)#}
-- experimental/commodities: cross-cutting the same way TimeUnit is (UnitOfMeasureType is used by
-- both UnitOfMeasure itself and, in a later stage, CommodityPricingHelper/EnergyCommodity).
-- Quantity's C tag is renamed QuantityUnit in cbits/qlEnumC2HS.h to avoid colliding with the
-- Quantity class bound in QuantLib.Commodity.
{#enum UnitOfMeasureType{} deriving (Show, Eq, Read, Bounded)#}
{#enum PaymentTermEventType{} deriving (Show, Eq, Read, Bounded)#}
-- experimental/commodities/commodity.hpp (PricingError::Level) and
-- experimental/commodities/energycommodity.hpp (EnergyCommodity::DeliverySchedule,
-- EnergyCommodity::QuantityPeriodicity), homed here for the same cross-cutting reason as
-- UnitOfMeasureType above (used by both EnergyCommodity's leaf constructors and
-- CommodityPricingHelper::createPricingPeriods, both in QuantLib.Instrument.Energy -- a later
-- stage than this module).
{#enum PricingErrorLevel{} deriving (Show, Eq, Read, Bounded)#}
peekPricingErrorLevelArray :: Ptr CUInt -> Ptr (Ptr CInt) -> IO [PricingErrorLevel]
peekPricingErrorLevelArray = peekIntArray' toEnumC
-- Prefix these tags to avoid clashes with QuantLib.Time.Schedule's Frequency constructors.
{#enum DeliverySchedule{} add prefix = "Delivery" deriving (Show, Eq, Read, Bounded)#}
{#enum QuantityPeriodicity{} deriving (Show, Eq, Read, Bounded)#}
-- CPI interpolation skips upstream's deprecated AsIndex value, so the enum starts at 1.
-- Shared users import it from here to avoid a module cycle.
{#enum CPIInterpolationType{} deriving (Show, Eq, Read, Bounded)#}
{#enum CalibrationBasketType{} deriving (Show, Eq, Read, Bounded)#}

-- |How an overnight leg observes its index fixings. Shared by every overnight-leg producer:
-- the swap constructors, the OIS rate helpers, and the cross-currency swaps. 'lookbackDays'
-- is 'Nothing' for upstream's @Null@ default, meaning the index's own fixing days.
--
-- Declared here rather than in a topical module because its producers span
-- "QuantLib.Instrument.Swap" and "QuantLib.TermStructure.Yield", whose build order cannot
-- accommodate one importing the other.
data OvernightObservation = OvernightObservation
  { lookbackDays :: !(Maybe Word)
  , lockoutDays :: !Word
  , applyObservationShift :: !Bool
  } deriving (Eq, Show)

-- |Upstream's own defaults: index fixing days, no lockout, no observation shift.
defaultOvernightObservation :: OvernightObservation
defaultOvernightObservation = OvernightObservation Nothing 0 False

-- Payoff/Exercise pointer hierarchy: the Finalizable/Upcastable instances and raw phantom
-- tags (CPayoff' etc.) live in QuantLib.Internal.Type alongside every other class hierarchy;
-- these are just c2hs-local aliases so {#fun#} specs below can keep writing the bare `QlX'
-- names, resolving to a raw, unwrapped Ptr (no auto-generated foreign-pointer code) since
-- construction/upcasting is handled by hand in the with* functions further down.
type QlPayoff = Ptr CPayoff'
type QlBasketPayoff = Ptr CBasketPayoff'
type QlTypePayoff = Ptr CTypePayoff'
type QlStrikedTypePayoff = Ptr CStrikedTypePayoff'
type QlPercentageStrikePayoff = Ptr CPercentageStrikePayoff'
type QlPlainVanillaPayoff = Ptr CPlainVanillaPayoff'
type QlExercise = Ptr CExercise'
type QlEuropeanExercise = Ptr CEuropeanExercise'
type QlAmericanExercise = Ptr CAmericanExercise'
type QlSwingExercise = Ptr CSwingExercise'
type QlBermudanExercise = Ptr CBermudanExercise'
type QlRebatedExercise = Ptr CRebatedExercise'
-- identity peek function: c2hs {#fun#} return specs always need a named out-marshaller,
-- even when (as here) construction should just hand back the raw, un-wrapped pointer.
peekPtr :: Ptr a -> IO (Ptr a)
peekPtr = pure
{#pointer *QlPayoff nocode#}
{#pointer *QlBasketPayoff nocode#}
{#pointer *QlTypePayoff nocode#}
{#pointer *QlStrikedTypePayoff nocode#}
{#pointer *QlPercentageStrikePayoff nocode#}
{#pointer *QlPlainVanillaPayoff nocode#}
{#pointer *QlExercise nocode#}
{#pointer *QlEuropeanExercise nocode#}
{#pointer *QlAmericanExercise nocode#}
{#pointer *QlSwingExercise nocode#}
{#pointer *QlBermudanExercise nocode#}
{#pointer *QlRebatedExercise nocode#}
{#pointer *Calendar foreign -> CCalendar nocode#}
{#pointer *QlCallability foreign -> CQlCallability nocode#}
{#pointer *QlOptimizationMethod as QlOptimizationMethod foreign -> COptimizationMethod nocode#}
{#pointer *QlEndCriteria as QlEndCriteria foreign -> CEndCriteria nocode#}
{#pointer *Constraint as QlConstraint foreign -> CConstraint nocode#}
{#pointer *FdmSchemeDesc as QlFdmSchemeDesc foreign -> CFdmSchemeDesc nocode#}
{#pointer *FittedBondDiscountCurveFittingMethod as QlFittedBondDiscountCurveFittingMethod foreign -> CFittedBondDiscountCurveFittingMethod nocode#}
{#pointer *QlClaim as Claim foreign -> CQlClaim nocode#}
{#pointer *QlBond as Bond foreign -> CBond' nocode#}
{#pointer *QlLmCorrelationModel foreign -> CLmCorrelationModel nocode#}
{#pointer *QlLmVolatilityModel foreign -> CLmVolatilityModel nocode#}
{#pointer *Rounding as QlRounding foreign -> CRounding nocode#}
{#pointer *QlAdditionalResult as RawResultPtr nocode#}

-- |Discriminants for `QlAdditionalResult.type`, bound from `enum AdditionalResultType` in
-- `cbits/qlInstrument.h` (read from the header, not hardcoded).
{#enum AdditionalResultType {} deriving (Show, Eq, Read) #}

-- monotonic flag for CubicInterpolation::Spline/::Parabolic -- tells deriveCrossEnum to give
-- these two values a runtime Bool field instead of cross-producting named sub-values (same
-- pattern as Actual360Convention etc. in CalendarEnum.chs). Order matters here in a way it
-- doesn't for the ApproximationType enum itself: these two type synonyms (and ApproximationExtra
-- below) must be declared textually *above* the deriveCrossEnum splice, since a TH splice can
-- only see top-level declarations that already exist earlier in the same module -- classifySub's
-- lookupTypeName would silently miss them (falling back to NoSub, dropping the Bool field) if
-- they were moved below the splice.
type NaturalSplineMonotonic = Bool
type ParabolicMonotonic = Bool

-- every Approximation case is driven by ApproximationType itself, so unlike
-- CalendarExtra/DayCounterExtra/IborExtra there are no non-enum-driven cases to add here
data ApproximationExtra

$(deriveCrossEnum CrossEnumSpec
    { crossTypeName = "Approximation"
    , crossMapperFn = "qlApproximation"
    , crossMainEnum = ''ApproximationType
    , crossSubSuffix = "Monotonic"
    , crossExtraType = ''ApproximationExtra
    })

deriving instance Show Approximation
deriving instance Eq Approximation
deriving instance Read Approximation

-- Approximation and interpolation dispatch through `qlTermStructureAux.cpp` rather than a factory
-- table. New enum values need no Haskell change, but `dispatchInterpolation` (and `makeCubic` for
-- an approximation) still needs a matching C++ case; otherwise QuantLib fails at runtime.

qlInterpolation :: Interpolation -> (Int, (Int, Int))
qlInterpolation BackwardFlat = (fromEnum InterpolationBackwardFlat, (0, 0))
qlInterpolation ForwardFlat = (fromEnum InterpolationForwardFlat, (0, 0))
qlInterpolation Linear = (fromEnum InterpolationLinear, (0, 0))
qlInterpolation LogLinear = (fromEnum InterpolationLogLinear, (0, 0))
qlInterpolation (Cubic x) = (fromEnum InterpolationCubic, qlApproximation x)
qlInterpolation (LogCubic x) = (fromEnum InterpolationLogCubic, qlApproximation x)
qlInterpolation Abcd = (fromEnum InterpolationAbcd, (0, 0))

qlInterpolation' :: Maybe Interpolation -> (Int, (Int, Int))
qlInterpolation' Nothing = (fromIntegral qlNullInteger, (0, 0))
qlInterpolation' (Just i) = qlInterpolation i

data Interpolation =
  BackwardFlat
  | ForwardFlat
  | Linear
  | LogLinear
  | Cubic !Approximation
  | LogCubic !Approximation
  | Abcd
  deriving (Show, Eq)

data EuropeanExercise = EuropeanExercise Day

-- | Use 'swingExerice' to construct 'Exercise'
data SwingExercise =
    SwingListExercise !(NonEmpty (Day, Word)) -- ^(dates, seconds)
    | SwingIntervalExercise !Day !Day !Word -- ^stepSizeSecs
data BermudanExercise =
    BermudanExercise !(NonEmpty Day) !Bool
    | Swing SwingExercise

-- | > Exercise
-- >  American
-- >  Early
-- >  Vanilla
-- >  EuropeanExercise
-- >  BermudanExercise
-- >    SwingExercise
-- >  Rebated (wraps another Exercise)
data Exercise =
    American
      !(Maybe Day) -- ^earliestDate
      !Day -- ^latestDate
      !Bool -- ^paoffAtExpiry
    | Early !ExerciseType !Bool
    | Vanilla !ExerciseType
    | European !EuropeanExercise
    | Bermudan !BermudanExercise
    | Rebated
        !Exercise -- ^wrapped exercise
        !Double -- ^rebate
        !Word -- ^rebateSettlementDays
        !Calendar -- ^rebatePaymentCalendar
        !BusinessDayConvention -- ^rebatePaymentConvention

-- |Candidate indices for broken IBOR periods, selected by nearest maturity or interpolated
-- between bracketing maturities in calendar days. Candidates keep their own curves and histories.
-- Their currency, fixing days/calendar and day counter must match; enable indexed coupons
-- when supplying a selection. Requires QuantLib 1.44.
data StubIndexSelection ibor
  = ClosestStubIndex !(NonEmpty (GenIborIndex ibor))
  | InterpolatedStubIndexes !(NonEmpty (GenIborIndex ibor))

type StubSelectionPtr = Ptr CStubIndexSelection'
{#pointer *QlStubIndexSelection nocode#}
{#pointer *QlIborIndex as IborIndex foreign -> CIborIndex' nocode#}

withStubIndexSelection :: Maybe (StubIndexSelection ibor) -> (Ptr CStubIndexSelection' -> IO r) -> IO r
withStubIndexSelection Nothing f = f nullPtr
withStubIndexSelection (Just selection) f = case selection of
  ClosestStubIndex indices -> withConstructed (stubIndexSelectionRaw 0 (toList indices)) f
  InterpolatedStubIndexes indices -> withConstructed (stubIndexSelectionRaw 1 (toList indices)) f

{#fun qlExercise{`ExerciseType',preErrorCheck-`String'errorCheck*-}->`QlExercise'peekPtr*#}
{#fun qlAmericanExercise{withDay*`Day',withDay*`Day',`Bool',preErrorCheck-`String'errorCheck*-}->`QlAmericanExercise'peekPtr*#}
{#fun qlAmericanExercise1{withDay*`Day',`Bool',preErrorCheck-`String'errorCheck*-}->`QlAmericanExercise'peekPtr*#}
{#fun qlBermudanExercise{withDayArray*`[Day]'&,`Bool',preErrorCheck-`String'errorCheck*-}->`QlBermudanExercise'peekPtr*#}
{#fun qlEarlyExercise{`ExerciseType',`Bool',preErrorCheck-`String'errorCheck*-}->`QlExercise'peekPtr*#}
{#fun qlEuropeanExercise{withDay*`Day',preErrorCheck-`String'errorCheck*-}->`QlEuropeanExercise'peekPtr*#}
{#fun qlSwingExercise{withDayArray*`[Day]'&,withIntArray*`[Word]'&,preErrorCheck-`String'errorCheck*-}->`QlSwingExercise'peekPtr*#}
{#fun qlSwingExercise1{withDay*`Day',withDay*`Day',fromIntegral`Word',preErrorCheck-`String'errorCheck*-}->`QlSwingExercise'peekPtr*#}
{#fun qlRebatedExercise{`QlExercise',`Double',fromIntegral`Word',withCalendar*`Calendar',fromEnumC`BusinessDayConvention',preErrorCheck-`String'errorCheck*-}->`QlRebatedExercise'peekPtr*#}

withEuropeanExercise :: EuropeanExercise -> (QlEuropeanExercise -> IO a) -> IO a
withEuropeanExercise (EuropeanExercise d) f = withConstructed (qlEuropeanExercise d) f

withSwingExercise :: SwingExercise -> (QlSwingExercise -> IO a) -> IO a
withSwingExercise (SwingListExercise ds) f = withConstructed (uncurry qlSwingExercise (unzip (toList ds))) f
withSwingExercise (SwingIntervalExercise d1 d2 s) f = withConstructed (qlSwingExercise1 d1 d2 s) f

withBermudanExercise :: BermudanExercise -> (QlBermudanExercise -> IO a) -> IO a
withBermudanExercise (BermudanExercise d p) f = withConstructed (qlBermudanExercise (toList d) p) f
withBermudanExercise (Swing e) f = withSwingExercise e (\sp -> withUpcast sp f)

withExercise :: Exercise -> (QlExercise -> IO a) -> IO a
withExercise (American Nothing d p) f = withConstructedUpcast (qlAmericanExercise1 d p) f
withExercise (American (Just d0) d p) f = withConstructedUpcast (qlAmericanExercise d0 d p) f
withExercise (Early t p) f = withConstructed (qlEarlyExercise t p) f
withExercise (Vanilla t) f = withConstructed (qlExercise t) f
withExercise (European e) f = withEuropeanExercise e (\ep -> withUpcast ep f)
withExercise (Bermudan e) f = withBermudanExercise e (\bp -> withUpcast bp f)
withExercise (Rebated e rebate days cal bdc) f = withExercise e (\ep -> withConstructedUpcast (qlRebatedExercise ep rebate days cal bdc) f)

-- | use 'percentageStrikePayoff' to construct 'Payoff'
data PercentageStrikePayoff = PercentageStrikePayoff
      !OptionType -- ^type
      !Double -- ^moneyness

-- | use 'plainVanillaPayoff' to construct 'Payoff'
data PlainVanillaPayoff = PlainVanillaPayoff
      !OptionType -- ^type
      !Double -- ^strike

-- | use 'strikedPayoff' to construct 'Payoff'
data StrikedPayoff =
  AssetOrNothing
    !OptionType -- ^type
    !Double -- ^strike
  | CashOrNothing
      !OptionType -- ^type
      !Double -- ^strike
      !Double -- ^cashPayoff
  | Gap
      !OptionType -- ^type
      !Double -- ^strike
      !Double -- ^secondStrike
  | PercentageStrike !PercentageStrikePayoff
  | PlainVanilla !PlainVanillaPayoff
  | SuperFund
      !Double -- ^strike
      !Double -- ^secondStrike
  | SuperSharePayoff
      !Double -- ^strike
      !Double -- ^secondStrike
      !Double -- ^cashPayoff
  -- |A Haskell-defined payoff carrying an advisory @(type, strike)@ pair. Build it with
  -- 'withCustomStrikedPayoff'.
  | CustomStriked
      !OptionType -- ^type
      !Double -- ^strike
      !String -- ^name
      !Callback

withPercentageStrikePayoff :: PercentageStrikePayoff -> (QlPercentageStrikePayoff -> IO a) -> IO a
withPercentageStrikePayoff (PercentageStrikePayoff t m) f = withConstructed (qlPercentageStrikePayoff t m) f

withPlainVanillaPayoff :: PlainVanillaPayoff -> (QlPlainVanillaPayoff -> IO a) -> IO a
withPlainVanillaPayoff (PlainVanillaPayoff t s) f = withConstructed (qlPlainVanillaPayoff t s) f

withStrikedPayoff :: StrikedPayoff -> (QlStrikedTypePayoff -> IO a) -> IO a
withStrikedPayoff (AssetOrNothing t s) f = withConstructed (qlAssetOrNothingPayoff t s) f
withStrikedPayoff (CashOrNothing t s c) f = withConstructed (qlCashOrNothingPayoff t s c) f
withStrikedPayoff (Gap t s ss) f = withConstructed (qlGapPayoff t s ss) f
withStrikedPayoff (PercentageStrike p) f = withPercentageStrikePayoff p (\pp -> withUpcast pp f)
withStrikedPayoff (PlainVanilla p) f = withPlainVanillaPayoff p (\pp -> withUpcast pp f)
withStrikedPayoff (SuperFund s ss) f = withConstructed (qlSuperFundPayoff s ss) f
withStrikedPayoff (SuperSharePayoff s ss c) f = withConstructed (qlSuperSharePayoff s ss c) f
withStrikedPayoff (CustomStriked t k n fp) f = withConstructed (qlStrikedPayoffFromFunction t k n fp) f

data TypePayoff = Striked !StrikedPayoff
  | Floating !OptionType -- ^type
data BasketPayoff =
    Average
      !Payoff -- ^p
      !Word -- ^n
  | AverageMultiple
      !Payoff -- ^p
      ![Double] -- ^a
  | Max
      !Payoff -- ^p
  | Min
      !Payoff -- ^p
  | Spread
      !Payoff -- ^p
  -- |A Haskell-defined @accumulate@ over the underlying-state vector, wrapped around a base
  -- 'Payoff' exactly as 'Max'\/'Min'\/'Spread' are. Build it with 'withCustomBasketPayoff'.
  | CustomAccumulate
      !Payoff -- ^base payoff, applied to the accumulated value
      !Callback

withTypePayoff :: TypePayoff -> (QlTypePayoff -> IO a) -> IO a
withTypePayoff (Floating t) f = withConstructed (qlFloatingTypePayoff t) f
withTypePayoff (Striked s) f = withStrikedPayoff s (\sp -> withUpcast sp f)

withBasketPayoff :: BasketPayoff -> (QlBasketPayoff -> IO a) -> IO a
withBasketPayoff (Average p n) f = withPayoff p (\pp -> withConstructed (qlAverageBasketPayoff pp n) f)
withBasketPayoff (AverageMultiple p a) f = withPayoff p (\pp -> withConstructed (qlAverageBasketPayoff1 pp a) f)
withBasketPayoff (Max p) f = withPayoff p (\pp -> withConstructed (qlMaxBasketPayoff pp) f)
withBasketPayoff (Min p) f = withPayoff p (\pp -> withConstructed (qlMinBasketPayoff pp) f)
withBasketPayoff (Spread p) f = withPayoff p (\pp -> withConstructed (qlSpreadBasketPayoff pp) f)
withBasketPayoff (CustomAccumulate p fp) f = withPayoff p (\pp -> withConstructed (qlBasketPayoffFromFunction pp fp) f)

-- | > Payoff
-- >  DoubleStickyRatchet
-- >  ForwardType
-- >  RatchettMax
-- >  RatchetMin
-- >  StickyMax
-- >  StickyMin
-- >  Sticky
-- >  Custom
-- >  TypePayoff
-- >    Floating
-- >    Striked
-- >      AssetOrNothing
-- >      CashOrNothing
-- >      Gap
-- >      PercentageStrike
-- >      PlainVanilla
-- >      SuperFund
-- >      SuperSharePayoff
-- >      CustomStriked
-- >  BasketPayoff
-- >    Average
-- >    AverageMultiple
-- >    Max
-- >    Min
-- >    Spread
-- >    CustomAccumulate
data Payoff =
    DoubleStickyRatchet
      !Double -- ^type1
      !Double -- ^type2
      !Double -- ^gearing1
      !Double -- ^gearing2
      !Double -- ^gearing3
      !Double -- ^spread1
      !Double -- ^spread2
      !Double -- ^spread3
      !Double -- ^initialValue1
      !Double -- ^initialValue2
      !Double -- ^accrualFactor
  | ForwardType
      !PositionType -- ^type
      !Double -- ^strike
  | RatchetMax
      !Double -- ^gearing1
      !Double -- ^gearing2
      !Double -- ^gearing3
      !Double -- ^spread1
      !Double -- ^spread2
      !Double -- ^spread3
      !Double -- ^initialValue1
      !Double -- ^initialValue2
      !Double -- ^accrualFactor
  | RatchetMin
      !Double -- ^gearing1
      !Double -- ^gearing2
      !Double -- ^gearing3
      !Double -- ^spread1
      !Double -- ^spread2
      !Double -- ^spread3
      !Double -- ^initialValue1
      !Double -- ^initialValue2
      !Double -- ^accrualFactor
  | Ratchet
      !Double -- ^gearing1
      !Double -- ^gearing2
      !Double -- ^spread1
      !Double -- ^spread2
      !Double -- ^initialValue
      !Double -- ^accrualFactor
  | StickyMax
      !Double -- ^gearing1
      !Double -- ^gearing2
      !Double -- ^gearing3
      !Double -- ^spread1
      !Double -- ^spread2
      !Double -- ^spread3
      !Double -- ^initialValue1
      !Double -- ^initialValue2
      !Double -- ^accrualFactor
  | StickyMin
      !Double -- ^gearing1
      !Double -- ^gearing2
      !Double -- ^gearing3
      !Double -- ^spread1
      !Double -- ^spread2
      !Double -- ^spread3
      !Double -- ^initialValue1
      !Double -- ^initialValue2
      !Double -- ^accrualFactor
  | Sticky
      !Double -- ^gearing1
      !Double -- ^gearing2
      !Double -- ^spread1
      !Double -- ^spread2
      !Double -- ^initialValue
      !Double -- ^accrualFactor
  | Type !TypePayoff
  | Basket !BasketPayoff
  -- |A Haskell-defined payoff with a managed callback; build with 'withCustomPayoff'.
  | Custom
      !String -- ^name
      !String -- ^description
      !Callback


{#fun qlAssetOrNothingPayoff{`OptionType',`Double',preErrorCheck-`String'errorCheck*-}->`QlStrikedTypePayoff'peekPtr*#}
{#fun qlAverageBasketPayoff{`QlPayoff',fromIntegral`Word',preErrorCheck-`String'errorCheck*-}->`QlBasketPayoff'peekPtr*#}
{#fun qlCashOrNothingPayoff{`OptionType',`Double',`Double',preErrorCheck-`String'errorCheck*-}->`QlStrikedTypePayoff'peekPtr*#}
{#fun qlDoubleStickyRatchetPayoff{`Double',`Double',`Double',`Double',`Double',`Double',`Double',`Double',`Double',`Double',`Double',preErrorCheck-`String'errorCheck*-}->`QlPayoff'peekPtr*#}
{#fun qlFloatingTypePayoff{`OptionType',preErrorCheck-`String'errorCheck*-}->`QlTypePayoff'peekPtr*#}
{#fun qlForwardTypePayoff{`PositionType',`Double',preErrorCheck-`String'errorCheck*-}->`QlPayoff'peekPtr*#}
{#fun qlGapPayoff{`OptionType',`Double',`Double',preErrorCheck-`String'errorCheck*-}->`QlStrikedTypePayoff'peekPtr*#}
{#fun qlMaxBasketPayoff{`QlPayoff',preErrorCheck-`String'errorCheck*-}->`QlBasketPayoff'peekPtr*#}
{#fun qlMinBasketPayoff{`QlPayoff',preErrorCheck-`String'errorCheck*-}->`QlBasketPayoff'peekPtr*#}
{#fun qlPercentageStrikePayoff{`OptionType',`Double',preErrorCheck-`String'errorCheck*-}->`QlPercentageStrikePayoff'peekPtr*#}
{#fun qlPlainVanillaPayoff{`OptionType',`Double',preErrorCheck-`String'errorCheck*-}->`QlPlainVanillaPayoff'peekPtr*#}
{#fun qlRatchetMaxPayoff{`Double',`Double',`Double',`Double',`Double',`Double',`Double',`Double',`Double',preErrorCheck-`String'errorCheck*-}->`QlPayoff'peekPtr*#}
{#fun qlRatchetMinPayoff{`Double',`Double',`Double',`Double',`Double',`Double',`Double',`Double',`Double',preErrorCheck-`String'errorCheck*-}->`QlPayoff'peekPtr*#}
{#fun qlRatchetPayoff{`Double',`Double',`Double',`Double',`Double',`Double',preErrorCheck-`String'errorCheck*-}->`QlPayoff'peekPtr*#}
{#fun qlSpreadBasketPayoff{`QlPayoff',preErrorCheck-`String'errorCheck*-}->`QlBasketPayoff'peekPtr*#}
{#fun qlStickyMaxPayoff{`Double',`Double',`Double',`Double',`Double',`Double',`Double',`Double',`Double',preErrorCheck-`String'errorCheck*-}->`QlPayoff'peekPtr*#}
{#fun qlStickyMinPayoff{`Double',`Double',`Double',`Double',`Double',`Double',`Double',`Double',`Double',preErrorCheck-`String'errorCheck*-}->`QlPayoff'peekPtr*#}
{#fun qlStickyPayoff{`Double',`Double',`Double',`Double',`Double',`Double',preErrorCheck-`String'errorCheck*-}->`QlPayoff'peekPtr*#}
{#fun qlSuperFundPayoff{`Double',`Double',preErrorCheck-`String'errorCheck*-}->`QlStrikedTypePayoff'peekPtr*#}
{#fun qlSuperSharePayoff{`Double',`Double',`Double',preErrorCheck-`String'errorCheck*-}->`QlStrikedTypePayoff'peekPtr*#}
{#fun qlAverageBasketPayoff1{`QlPayoff',withDoubleArray*`[Double]'&,preErrorCheck-`String'errorCheck*-}->`QlBasketPayoff'peekPtr*#}
{#fun qlPayoffFromFunction{`String',`String',withCallbackPtr*`Callback',preErrorCheck-`String'errorCheck*-}->`QlPayoff'peekPtr*#}
{#fun qlBasketPayoffFromFunction{`QlPayoff',withCallbackPtr*`Callback',preErrorCheck-`String'errorCheck*-}->`QlBasketPayoff'peekPtr*#}
{#fun qlStrikedPayoffFromFunction{`OptionType',`Double',`String',withCallbackPtr*`Callback',preErrorCheck-`String'errorCheck*-}->`QlStrikedTypePayoff'peekPtr*#}

withPayoff :: Payoff -> (QlPayoff -> IO a) -> IO a
withPayoff (DoubleStickyRatchet t1 t2 g1 g2 g3 s1 s2 s3 i1 i2 a) f = withConstructed (qlDoubleStickyRatchetPayoff t1 t2 g1 g2 g3 s1 s2 s3 i1 i2 a) f
withPayoff (ForwardType t s) f = withConstructed (qlForwardTypePayoff t s) f
withPayoff (RatchetMax g1 g2 g3 s1 s2 s3 i1 i2 a) f = withConstructed (qlRatchetMaxPayoff g1 g2 g3 s1 s2 s3 i1 i2 a) f
withPayoff (RatchetMin g1 g2 g3 s1 s2 s3 i1 i2 a) f = withConstructed (qlRatchetMinPayoff g1 g2 g3 s1 s2 s3 i1 i2 a) f
withPayoff (Ratchet g1 g2 s1 s2 i a) f = withConstructed (qlRatchetPayoff g1 g2 s1 s2 i a) f
withPayoff (StickyMax g1 g2 g3 s1 s2 s3 i1 i2 a) f = withConstructed (qlStickyMaxPayoff g1 g2 g3 s1 s2 s3 i1 i2 a) f
withPayoff (StickyMin g1 g2 g3 s1 s2 s3 i1 i2 a) f = withConstructed (qlStickyMinPayoff g1 g2 g3 s1 s2 s3 i1 i2 a) f
withPayoff (Sticky g1 g2 s1 s2 i a) f = withConstructed (qlStickyPayoff g1 g2 s1 s2 i a) f
withPayoff (Type t) f = withTypePayoff t (\tp -> withUpcast tp f)
withPayoff (Basket b) f = withBasketPayoff b (\bp -> withUpcast bp f)
withPayoff (Custom n d fp) f = withConstructed (qlPayoffFromFunction n d fp) f

-- |Wrap a Haskell @price -> value@ function as a real QuantLib @Payoff@, usable anywhere a
-- 'Payoff' is (@QuantLib.Instrument.Option.oneAssetOption@, @multiAssetOption@,
-- @QuantLib.Instrument.Swap.varianceOption@, @QuantLib.Method.fdmLogInnerValue@,
-- @fdmCellAveragingInnerValue@, ...) -- the fully custom counterpart to the concrete
-- pre-implemented payoffs listed by the 'Payoff' constructors above.
--
-- The payoff ADT and every native consumer retain the callback after the continuation returns.
-- Callback exceptions are rethrown by the enclosing Haskell call.
--
-- @name@ and @description@ are what QuantLib's own error messages and @Payoff::name@ report; they
-- are not interpreted.
--
-- __Not every engine accepts a non-standard payoff.__ QuantLib's analytic, binomial, finite-
-- difference and @MCEuropeanEngine@ families all recover the strike by downcasting to
-- @StrikedTypePayoff@\/@PlainVanillaPayoff@ first, and a further ~30 engines route through
-- @BlackCalculator@, whose @AcyclicVisitor@ knows only the four built-in striked payoffs. Most of
-- these fail with a clean QuantLib exception. The two bound finite-difference vanilla engines
-- validate the required striked payoff, including on QuantLib 1.43. Confirmed-generic consumers:
-- @QuantLib.Method.fdmLogInnerValue@\/@fdmCellAveragingInnerValue@ (and hence @fdmSolve@), and
-- @QuantLib.PricingEngine.mcAmericanEngine@ with @controlVariate = False@.
withCustomPayoff :: String -- ^name
  -> String -- ^description
  -> (Double -> Double) -- ^payoff(price)
  -> (Payoff -> IO b) -> IO b
withCustomPayoff n d f k = withPayoffFun f (k . Custom n d)

-- |As 'withCustomPayoff', but produces a real QuantLib @StrikedTypePayoff@ carrying an
-- @(optionType, strike)@ pair alongside the Haskell function.
--
-- __The pair is advisory: it does not define the payoff__ -- @payoff(price)@ alone does, exactly
-- as for 'withCustomPayoff'. It exists because QuantLib's finite-difference vanilla engines reach
-- past the @Payoff@ interface for a strike when sizing their grid:
-- @FdBlackScholesVanillaEngine@ @dynamic_pointer_cast@s to @StrikedTypePayoff@ and calls
-- @strike()@ twice -- once for the mesher's extent, once for its node-concentration point -- then
-- hands the payoff itself to @FdmLogInnerValue@, which takes a plain @Payoff@. So a payoff built
-- here prices correctly through 'QuantLib.PricingEngine.fdBlackScholesVanillaEngine' and
-- 'QuantLib.PricingEngine.fdHestonVanillaEngine', where one built by 'withCustomPayoff' is
-- rejected with an exception. Pass the strike you want the grid centred on.
--
-- The payoff and native consumers retain the callback after the continuation returns.
-- @description@ is derived from the type and strike by @StrikedTypePayoff@.
--
-- Engines routing through @BlackCalculator@ (the @analytic*@ family) still reject this, as they
-- must: its @AcyclicVisitor@ knows only the four built-in striked payoffs, and there is no
-- closed-form price for an arbitrary function. That rejection is a clean QuantLib exception.
withCustomStrikedPayoff :: OptionType -- ^advisory option type
  -> Double -- ^advisory strike (grid centring only)
  -> String -- ^name
  -> (Double -> Double) -- ^payoff(price)
  -> (StrikedPayoff -> IO b) -> IO b
withCustomStrikedPayoff t k n f g = withPayoffFun f (g . CustomStriked t k n)

-- |Wrap a Haskell @underlyings -> accumulated@ function as a real QuantLib @BasketPayoff@ around
-- @base@ (which is applied to the accumulated value, exactly as for 'Max'\/'Min'\/'Spread') --
-- usable with @QuantLib.Instrument.Option.basketOption@ and
-- @QuantLib.Method.fdmLogBasketInnerValue@. Same ownership rule as 'withCustomPayoff';
-- unlike it, this callback crosses once per evaluation with the whole underlying-state vector,
-- because that is the shape @BasketPayoff::accumulate@ already has upstream.
withCustomBasketPayoff :: Payoff -- ^base payoff
  -> ([Double] -> Double) -- ^accumulate(underlyings)
  -> (BasketPayoff -> IO b) -> IO b
withCustomBasketPayoff base f k = withBasketAccumulateFun f (k . CustomAccumulate base)

data Callability =
  Soft
    !(Double, BondPriceType)
    !Day
    !Double -- ^trigger
  | Callability
      !(Double, BondPriceType)
      !CallabilityType
      !Day

callability :: Callability -> IO (Standalone CQlCallability)
callability (Soft (p, t) d tg) = qlSoftCallability p t d tg
callability (Callability (p, t) ct d) = qlCallability p t ct d

newtype EnumMeta a b = EnumMeta (a -> IO (Standalone b))

withEnumType :: EnumMeta a b -> a -> (Ptr b -> IO c) -> IO c
withEnumType (EnumMeta t) x f = t x >>= (`withStandalone` f)

withMaybeEnumType :: EnumMeta a b -> Maybe a -> (Ptr b -> IO c) -> IO c
withMaybeEnumType (EnumMeta t) x f = maybe (f nullPtr) (\xx -> t xx >>= (`withStandalone` f)) x

withEnumTypeArray :: EnumMeta a b -> [a] -> ((CUInt, Ptr (Ptr b)) -> IO c) -> IO c
withEnumTypeArray m x f = withMany (withEnumType m) x (`withArray` (\px -> f (fromIntegral $ length x, px)))

callabilityMeta :: EnumMeta Callability CQlCallability
callabilityMeta = EnumMeta callability

withCallability :: Callability -> (Ptr CQlCallability -> IO a) -> IO a
withCallability = withEnumType callabilityMeta

withCallabilityArray :: [Callability] -> ((CUInt, Ptr (Ptr CQlCallability)) -> IO c) -> IO c
withCallabilityArray = withEnumTypeArray callabilityMeta

constraintMeta :: EnumMeta Constraint CConstraint
constraintMeta = EnumMeta constraint

roundingMeta :: EnumMeta Rounding CRounding
roundingMeta = EnumMeta rounding

withMaybeConstraint :: Maybe Constraint -> (Ptr CConstraint -> IO a) -> IO a
withMaybeConstraint = withMaybeEnumType constraintMeta

withMaybeRounding :: Maybe Rounding -> (Ptr CRounding -> IO a) -> IO a
withMaybeRounding = withMaybeEnumType roundingMeta

withConstraint :: Constraint -> (Ptr CConstraint -> IO a) -> IO a
withConstraint = withEnumType constraintMeta

withRounding :: Rounding -> (Ptr CRounding -> IO a) -> IO a
withRounding = withEnumType roundingMeta

fittedBondDiscountFittingMethodMeta :: EnumMeta FittingMethod CFittedBondDiscountCurveFittingMethod
fittedBondDiscountFittingMethodMeta = EnumMeta fittingMethod

withFittedBondDiscountCurveFittingMethod :: FittingMethod -> (Ptr CFittedBondDiscountCurveFittingMethod -> IO a) -> IO a
withFittedBondDiscountCurveFittingMethod = withEnumType fittedBondDiscountFittingMethodMeta

endCriteriaMeta :: EnumMeta EndCriteria CEndCriteria
endCriteriaMeta = EnumMeta endCriteria

withEndCriteria :: EndCriteria -> (Ptr CEndCriteria -> IO a) -> IO a
withEndCriteria = withEnumType endCriteriaMeta

withMaybeEndCriteria :: Maybe EndCriteria -> (Ptr CEndCriteria -> IO a) -> IO a
withMaybeEndCriteria = withMaybeEnumType endCriteriaMeta

fdmSchemeDescMeta :: EnumMeta FdmScheme CFdmSchemeDesc
fdmSchemeDescMeta = EnumMeta fdmScheme

withFdmSchemeDesc :: FdmScheme -> (Ptr CFdmSchemeDesc -> IO a) -> IO a
withFdmSchemeDesc = withEnumType fdmSchemeDescMeta

optimizationMethodMeta :: EnumMeta OptimizationMethod COptimizationMethod
optimizationMethodMeta = EnumMeta optimizationMethod

withOptimizationMethod :: OptimizationMethod -> (Ptr COptimizationMethod -> IO a) -> IO a
withOptimizationMethod = withEnumType optimizationMethodMeta

withMaybeOptimizationMethod :: Maybe OptimizationMethod -> (Ptr COptimizationMethod -> IO a) -> IO a
withMaybeOptimizationMethod = withMaybeEnumType optimizationMethodMeta

-- Payoff/Exercise with* functions are now defined directly, near their ADTs, using
-- Upcastable/GenForeignPtr (see QuantLib.Internal.Type) instead of EnumMeta'/IsQlPayoff/IsQlExercise.

-- |callability leaving to the holder the possibility to convert
{#fun qlSoftCallability{`Double',`BondPriceType',withDay*`Day',`Double',preErrorCheck-`String'errorCheck*-}->`QlCallability'peekCallability*#}
{#fun qlCallability{`Double',`BondPriceType',`CallabilityType',withDay*`Day',preErrorCheck-`String'errorCheck*-}->`QlCallability'peekCallability*#}

-- Every constructor below binds the QuantLib overload's leading optimizationMethod param via a
-- trailing Maybe OptimizationMethod field (Nothing -> upstream's own empty-shared_ptr default,
-- letting the fit fall back to LevenbergMarquardt). OptimizationMethod's hasquant-side handle
-- (QlOptimizationMethod) is a shared_ptr box, not a raw Haskell-finalized pointer -- see the
-- qlaux.h comment above the QlEndCriteria/QlOptimizationMethod typedefs -- so a caller-supplied
-- one can safely be copied into FittingMethod's own shared_ptr member (and survive
-- FittedBondDiscountCurve cloning the fitting method) regardless of when Haskell's own box is
-- collected.
data FittingMethod =
  CubicBSplines
    ![Double] -- ^knotVector (year fraction)
    !Bool -- ^constrainAtZero
    ![Double] -- ^weights
    ![Double] -- ^l2
    !Double -- ^minCutoffTime
    !Double -- ^maxCutoffTime
    !(Maybe Constraint)
    !(Maybe OptimizationMethod)
  | ExponentialSplines
    !Bool -- ^constrainAtZero
    ![Double] -- ^weights
    ![Double] -- ^l2
    !Double -- ^minCutoffTime
    !Double -- ^maxCutoffTime
    !Word -- ^numCoeffs
    !(Maybe Double) -- ^fixedKappa
    !(Maybe Constraint)
    !(Maybe OptimizationMethod)
  | NelsonSiegel
    ![Double] -- ^weights
    ![Double] -- ^l2
    !Double -- ^minCutoffTime
    !Double -- ^maxCutoffTime
    !(Maybe Constraint)
    !(Maybe OptimizationMethod)
  | SimplePolynomial
    !Word -- ^degree
    !Bool -- ^constrainAtZero
    ![Double] -- ^weights
    ![Double] -- ^l2
    !Double -- ^minCutoffTime
    !Double -- ^maxCutoffTime
    !(Maybe Constraint)
    !(Maybe OptimizationMethod)
  | Svensson
    ![Double] -- ^weights
    ![Double] -- ^l2
    !Double -- ^minCutoffTime
    !Double -- ^maxCutoffTime
    !(Maybe Constraint)
    !(Maybe OptimizationMethod)

fittingMethod :: FittingMethod -> IO QlFittedBondDiscountCurveFittingMethod
fittingMethod (CubicBSplines k c w l2 mn mx cn om) = qlCubicBSplinesFitting k c w l2 mn mx om cn
fittingMethod (ExponentialSplines c w l2 mn mx n fk cn om) = qlExponentialSplinesFitting c w l2 mn mx n fk om cn
fittingMethod (NelsonSiegel w l2 mn mx cn om) = qlNelsonSiegelFitting w l2 mn mx om cn
fittingMethod (SimplePolynomial d c w l2 mn mx cn om) = qlSimplePolynomialFitting d c w l2 mn mx om cn
fittingMethod (Svensson w l2 mn mx cn om) = qlSvenssonFitting w l2 mn mx om cn

{#fun qlCubicBSplinesFitting{withDoubleArray*`[Double]'&,`Bool'
  ,withDoubleArray*`[Double]'& -- ^weights
  ,withDoubleArray*`[Double]'& -- ^l2
  ,`Double' -- ^minCutoffTime
  ,`Double' -- ^maxCutoffTime
  ,withMaybeOptimizationMethod*`Maybe OptimizationMethod'
  ,withMaybeConstraint*`Maybe Constraint'
  ,preErrorCheck-`String'errorCheck*-}->`QlFittedBondDiscountCurveFittingMethod'peekFittedBondDiscountCurveFittingMethod*#}
{#fun qlExponentialSplinesFitting{`Bool'
  ,withDoubleArray*`[Double]'& -- ^weights
  ,withDoubleArray*`[Double]'& -- ^l2
  ,`Double' -- ^minCutoffTime
  ,`Double' -- ^maxCutoffTime
  ,fromIntegral`Word' -- ^numCoeffs
  ,fromMaybeDouble`Maybe Double' -- ^fixedKappa
  ,withMaybeOptimizationMethod*`Maybe OptimizationMethod'
  ,withMaybeConstraint*`Maybe Constraint'
  ,preErrorCheck-`String'errorCheck*-}->`QlFittedBondDiscountCurveFittingMethod'peekFittedBondDiscountCurveFittingMethod*#}
{#fun qlNelsonSiegelFitting{withDoubleArray*`[Double]'& -- ^weights
  ,withDoubleArray*`[Double]'& -- ^l2
  ,`Double' -- ^minCutoffTime
  ,`Double' -- ^maxCutoffTime
  ,withMaybeOptimizationMethod*`Maybe OptimizationMethod'
  ,withMaybeConstraint*`Maybe Constraint'
  ,preErrorCheck-`String'errorCheck*-}->`QlFittedBondDiscountCurveFittingMethod'peekFittedBondDiscountCurveFittingMethod*#}
{#fun qlSimplePolynomialFitting{fromIntegral`Word',`Bool'
  ,withDoubleArray*`[Double]'& -- ^weights
  ,withDoubleArray*`[Double]'& -- ^l2
  ,`Double' -- ^minCutoffTime
  ,`Double' -- ^maxCutoffTime
  ,withMaybeOptimizationMethod*`Maybe OptimizationMethod'
  ,withMaybeConstraint*`Maybe Constraint'
  ,preErrorCheck-`String'errorCheck*-}->`QlFittedBondDiscountCurveFittingMethod'peekFittedBondDiscountCurveFittingMethod*#}
{#fun qlSvenssonFitting{withDoubleArray*`[Double]'& -- ^weights
  ,withDoubleArray*`[Double]'& -- ^l2
  ,`Double' -- ^minCutoffTime
  ,`Double' -- ^maxCutoffTime
  ,withMaybeOptimizationMethod*`Maybe OptimizationMethod'
  ,withMaybeConstraint*`Maybe Constraint'
  ,preErrorCheck-`String'errorCheck*-}->`QlFittedBondDiscountCurveFittingMethod'peekFittedBondDiscountCurveFittingMethod*#}

data FdmScheme =
  FdmScheme
    !FdmSchemeType -- ^type
    !Double -- ^theta
    !Double -- ^mu
  | CraigSneyd
  | Douglas
  | ExplicitEuler
  | Hundsdorfer
  | ImplicitEuler
  | ModifiedCraigSneyd
  | ModifiedHundsdorfer
  | MethodOfLines
    !Double -- ^eps
    !Double -- ^relInitStepSize

{#fun qlFdmSchemeDesc{`FdmSchemeType',`Double',`Double',preErrorCheck-`String'errorCheck*-}->`QlFdmSchemeDesc'peekFdmSchemeDesc*#}
{#fun qlFdmSchemeDescCraigSneyd{preErrorCheck-`String'errorCheck*-}->`QlFdmSchemeDesc'peekFdmSchemeDesc*#}
{#fun qlFdmSchemeDescDouglas{preErrorCheck-`String'errorCheck*-}->`QlFdmSchemeDesc'peekFdmSchemeDesc*#}
{#fun qlFdmSchemeDescExplicitEuler{preErrorCheck-`String'errorCheck*-}->`QlFdmSchemeDesc'peekFdmSchemeDesc*#}
{#fun qlFdmSchemeDescHundsdorfer{preErrorCheck-`String'errorCheck*-}->`QlFdmSchemeDesc'peekFdmSchemeDesc*#}
{#fun qlFdmSchemeDescImplicitEuler{preErrorCheck-`String'errorCheck*-}->`QlFdmSchemeDesc'peekFdmSchemeDesc*#}
{#fun qlFdmSchemeDescModifiedCraigSneyd{preErrorCheck-`String'errorCheck*-}->`QlFdmSchemeDesc'peekFdmSchemeDesc*#}
{#fun qlFdmSchemeDescModifiedHundsdorfer{preErrorCheck-`String'errorCheck*-}->`QlFdmSchemeDesc'peekFdmSchemeDesc*#}
{#fun qlFdmSchemeDescMethodOfLines{`Double' -- ^eps
  ,`Double' -- ^relInitStepSize
  ,preErrorCheck-`String'errorCheck*-}->`QlFdmSchemeDesc'peekFdmSchemeDesc*#}

fdmScheme :: FdmScheme -> IO QlFdmSchemeDesc
fdmScheme (FdmScheme t th mu) = qlFdmSchemeDesc t th mu
fdmScheme CraigSneyd = qlFdmSchemeDescCraigSneyd
fdmScheme Douglas = qlFdmSchemeDescDouglas
fdmScheme ExplicitEuler = qlFdmSchemeDescExplicitEuler
fdmScheme Hundsdorfer = qlFdmSchemeDescHundsdorfer
fdmScheme ImplicitEuler = qlFdmSchemeDescImplicitEuler
fdmScheme ModifiedCraigSneyd = qlFdmSchemeDescModifiedCraigSneyd
fdmScheme ModifiedHundsdorfer = qlFdmSchemeDescModifiedHundsdorfer
fdmScheme (MethodOfLines eps relInitStepSize) = qlFdmSchemeDescMethodOfLines eps relInitStepSize

data Constraint =
  Boundary
    !Double -- ^low
    !Double -- ^high
  | Composite
    !Constraint -- ^c1
    !Constraint -- ^c2
  | NoConstraint
  | PositiveConstraint

constraint :: Constraint -> IO QlConstraint
constraint (Boundary l h) = qlBoundaryConstraint l h
constraint (Composite c1 c2) = qlCompositeConstraint c1 c2
constraint NoConstraint = qlNoConstraint
constraint PositiveConstraint = qlPositiveConstraint

{#fun qlBoundaryConstraint{`Double',`Double',preErrorCheck-`String'errorCheck*-}->`QlConstraint'peekConstraint*#}
{#fun qlCompositeConstraint{withConstraint*`Constraint',withConstraint*`Constraint',preErrorCheck-`String'errorCheck*-}->`QlConstraint'peekConstraint*#}
{#fun qlNoConstraint{preErrorCheck-`String'errorCheck*-}->`QlConstraint'peekConstraint*#}
{#fun qlPositiveConstraint{preErrorCheck-`String'errorCheck*-}->`QlConstraint'peekConstraint*#}

data OptimizationMethod =
  LevenbergMarquardt
    !Double -- ^epsfcn
    !Double -- ^xtol
    !Double -- ^gtol
    !Bool -- ^useCostFunctionsJacobian
  | Simplex !Double -- ^lambda, characteristic length

optimizationMethod :: OptimizationMethod -> IO QlOptimizationMethod
optimizationMethod (LevenbergMarquardt e x g j) = qlLevenbergMarquardt e x g j
optimizationMethod (Simplex l) = qlSimplex l
{#fun qlLevenbergMarquardt{`Double',`Double',`Double',`Bool',preErrorCheck-`String'errorCheck*-}->`QlOptimizationMethod'peekOptimizationMethod*#}
{#fun qlSimplex{`Double',preErrorCheck-`String'errorCheck*-}->`QlOptimizationMethod'peekOptimizationMethod*#}

data EndCriteria =
  EndCriteria
    !Word -- ^maxIterations
    !Word -- ^maxStationaryStateIterations
    !Double -- ^rootEpsilon
    !Double -- ^functionEpsilon
    !Double -- ^gradientNormEpsilon

endCriteria :: EndCriteria -> IO QlEndCriteria
endCriteria (EndCriteria m1 m2 e f g) = qlEndCriteria m1 m2 e f g
{#fun qlEndCriteria{fromIntegral`Word',fromIntegral`Word',`Double',`Double',`Double',preErrorCheck-`String'errorCheck*-}->`QlEndCriteria'peekEndCriteria*#}

data Rounding = NoRounding
  | Rounding
    !Int -- ^precision
    !RoundingType
    !Int -- ^digit
  deriving (Show, Eq)

rounding :: Rounding -> IO QlRounding
rounding NoRounding = qlRounding
rounding (Rounding p t d) = qlRounding1 p t d

{#fun qlRounding{preErrorCheck-`String'errorCheck*-}->`QlRounding'peekRounding*#}
{#fun qlRounding1{`Int',`RoundingType',`Int',preErrorCheck-`String'errorCheck*-}->`QlRounding'peekRounding*#}

data LmCorrelationModel = ConstWrapperCorrelation LmCorrelationModel
  | ExponentialCorrelation Word -- ^size
    !Double -- ^rho
  | LinearExponentialCorrelation Word -- ^size
    !Double -- ^rho
    !Double -- ^beta
    !Word -- ^factors
  deriving (Show, Eq)

{#fun qlLmConstWrapperCorrelationModel{withStandalone*`QlLmCorrelationModel',preErrorCheck-`String'errorCheck*-}->`QlLmCorrelationModel'peekLmCorrelationModel*#}
{#fun qlLmExponentialCorrelationModel{fromIntegral`Word',`Double',preErrorCheck-`String'errorCheck*-}->`QlLmCorrelationModel'peekLmCorrelationModel*#}
{#fun qlLmLinearExponentialCorrelationModel{fromIntegral`Word',`Double',`Double',fromIntegral`Word',preErrorCheck-`String'errorCheck*-}->`QlLmCorrelationModel'peekLmCorrelationModel*#}

correlationModel :: LmCorrelationModel -> IO QlLmCorrelationModel
correlationModel (ConstWrapperCorrelation m) = correlationModel m >>= qlLmConstWrapperCorrelationModel
correlationModel (ExponentialCorrelation s r) = qlLmExponentialCorrelationModel s r
correlationModel (LinearExponentialCorrelation s r b f) = qlLmLinearExponentialCorrelationModel s r b f

correlationModelMeta :: EnumMeta LmCorrelationModel CLmCorrelationModel
correlationModelMeta = EnumMeta correlationModel

withLmCorrelationModel :: LmCorrelationModel -> (Ptr CLmCorrelationModel -> IO a) -> IO a
withLmCorrelationModel = withEnumType correlationModelMeta

data LmVolatilityModel = ConstWrapperVolatility LmVolatilityModel
  | FixedVolatility !(NonEmpty (Double, Double)) -- ^(start time, volatility)
  | LinearExponentialVolatility ![Double] -- ^fixing times
    !Double -- ^a
    !Double -- ^b
    !Double -- ^c
    !Double -- ^d
  deriving (Show, Eq)

{#fun qlLmConstWrapperVolatilityModel{withStandalone*`QlLmVolatilityModel',preErrorCheck-`String'errorCheck*-}->`QlLmVolatilityModel'peekLmVolatilityModel*#}
{#fun qlLmFixedVolatilityModel{withDoubleArray*`[Double]'&,withDoubleArray*`[Double]'&,preErrorCheck-`String'errorCheck*-}->`QlLmVolatilityModel'peekLmVolatilityModel*#}
{#fun qlLmLinearExponentialVolatilityModel{withDoubleArray*`[Double]'&,`Double',`Double',`Double',`Double',preErrorCheck-`String'errorCheck*-}->`QlLmVolatilityModel'peekLmVolatilityModel*#}

volatilityModel :: LmVolatilityModel -> IO QlLmVolatilityModel
volatilityModel (ConstWrapperVolatility m) = volatilityModel m >>= qlLmConstWrapperVolatilityModel
volatilityModel (FixedVolatility tv) = qlLmFixedVolatilityModel vols times
  where (times, vols) = unzip (toList tv)
volatilityModel (LinearExponentialVolatility s a b c d) = qlLmLinearExponentialVolatilityModel s a b c d

volatilityModelMeta :: EnumMeta LmVolatilityModel CLmVolatilityModel
volatilityModelMeta = EnumMeta volatilityModel

withLmVolatilityModel :: LmVolatilityModel -> (Ptr CLmVolatilityModel -> IO a) -> IO a
withLmVolatilityModel = withEnumType volatilityModelMeta

data Claim = FaceValue | forall b. FaceValueAccrual (GenBond b)
claimMeta :: EnumMeta Claim CQlClaim
claimMeta = EnumMeta claim

withClaim :: Claim -> (Ptr CQlClaim -> IO a) -> IO a
withClaim = withEnumType claimMeta

claim :: Claim -> IO QlClaim
claim FaceValue = qlFaceValueClaim
claim (FaceValueAccrual b) = qlFaceValueAccrualClaim b

-- |Claim on a notional
{#fun qlFaceValueClaim{preErrorCheck-`String'errorCheck*-}->`QlClaim'peekClaim*#}

-- |Claim on the notional of a reference security, including accrual
{#fun qlFaceValueAccrualClaim{withBond*`GenBond b',preErrorCheck-`String'errorCheck*-}->`QlClaim'peekClaim*#}

strikedPayoff :: StrikedPayoff -> Payoff
strikedPayoff = Type . Striked

percentageStrikePayoff :: PercentageStrikePayoff -> Payoff
percentageStrikePayoff = Type . Striked . PercentageStrike

plainVanillaPayoff :: PlainVanillaPayoff -> Payoff
plainVanillaPayoff = Type . Striked . PlainVanilla

swingExercise :: SwingExercise -> Exercise
swingExercise = Bermudan . Swing

-- |One value from QuantLib's `Instrument::additionalResults()` map. QuantLib stores the map as
-- `ext::any`, so this Haskell view picks three concrete shapes -- `Real` (`Double`), `std::string`
-- (`String`), `std::vector<Real>` (`[Double]`) -- plus an `UnsupportedVal` fallback recording the
-- value's C++ RTTI type name, so no key is ever silently dropped or mislabelled.
data AdditionalResultVal = RealVal Double | StringVal String | RealVectorVal [Double] | UnsupportedVal String
  deriving (Show, Eq)

type RawResultPtr = Ptr RawResult

-- |One raw `QlAdditionalResult` entry, peeked field-by-field via c2hs `{#get#}` hooks. Its
-- `Storable` instance (`sizeOf`/`alignment` from `{#sizeof#}`/`{#alignof#}`, both read straight
-- from the C struct layout, not hand-computed) is what lets `peekStructArray`
-- (`QuantLib.Internal`) walk the C array via a plain `peekArray`, rather than hand-rolled pointer
-- arithmetic.
data RawResult = RawResult
  { rKey :: CString, rType :: CInt, rDval :: CDouble
  , rSval :: CString, rVarr :: Ptr CDouble, rVlen :: CUInt }

instance Storable RawResult where
  sizeOf _ = {#sizeof QlAdditionalResult #}
  alignment _ = {#alignof QlAdditionalResult #}
  peek p = RawResult <$> {#get QlAdditionalResult.key #} p
                      <*> {#get QlAdditionalResult.type #} p
                      <*> {#get QlAdditionalResult.dval #} p
                      <*> {#get QlAdditionalResult.sval #} p
                      <*> {#get QlAdditionalResult.varr #} p
                      <*> {#get QlAdditionalResult.vlen #} p
  poke = error "RawResult is peek-only (read from C, never constructed in Haskell)"

-- |Convert one raw entry into its keyed Haskell value. `sval`/`varr` are only read for the
-- discriminant that owns them; their buffers are released in bulk afterwards, by
-- `qlFreeAdditionalResults`, not per-field here.
convertResult :: RawResult -> IO (String, AdditionalResultVal)
convertResult r = do
  key <- peekCString (rKey r)
  val <- case toEnum (fromIntegral (rType r)) of
    AdditionalResultDouble -> return (RealVal (realToFrac (rDval r)))
    AdditionalResultString -> StringVal <$> peekCString (rSval r)
    AdditionalResultDoubleVector -> RealVectorVal . map realToFrac
                                       <$> peekArray (fromIntegral (rVlen r)) (rVarr r)
    AdditionalResultUnknown -> UnsupportedVal <$> peekCString (rSval r)
  return (key, val)

-- |Peek the C array of `QlAdditionalResult` into a keyed list, then release the whole array (keys,
-- `sval`/`varr` buffers, and the array itself) in one `qlFreeAdditionalResults` call.
peekAdditionalResults :: Ptr CUInt -> Ptr RawResultPtr -> IO [(String, AdditionalResultVal)]
peekAdditionalResults = peekStructArray convertResult (\l p -> qlFreeAdditionalResults l (castPtr p))

-- vim: set ff=unix ts=8 sts=2 sw=2 et:

preAdditionalResults :: ((Ptr CUInt, Ptr RawResultPtr) -> IO b) -> IO b
preAdditionalResults = preArrayWith (\l p -> qlFreeAdditionalResults l (castPtr p))

{#fun qlStubIndexSelection as stubIndexSelectionRaw{`Int'
  ,withIborIndexArray*`[GenIborIndex ibor]'&
  ,preErrorCheck-`String'errorCheck*-}->`StubSelectionPtr'peekPtr*#}