-- TemplateHaskellQuotes, not TemplateHaskell: dropping the quotation brackets in favour of raw
-- constructors left only 'name / ''Name quotes, which the narrower extension covers
{-# LANGUAGE TemplateHaskellQuotes, LambdaCase #-}
module QuantLib.Internal.Syntax
  (
    CrossEnumSpec(..)
  , deriveCrossEnum
  , IborConstructorSpec(..)
  , deriveIborConstructor
  , deriveOptionsRecord
  , deriveReadPlain
  , deriveReadInstance
  ) where
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Lib(DecsQ, TypeQ, ExpQ, conP, plainTV)
import Data.List(isPrefixOf, isSuffixOf)
import Data.Maybe(catMaybes)
import Data.Char(isUpper, toLower, toUpper)
import Control.Monad((>=>))
import System.IO.Unsafe(unsafePerformIO)

-- All three derive functions below build their output as raw Dec/Con/Exp/Pat constructors
-- rather than quotation brackets or the Q combinators from TH.Lib, so the shape of what is
-- generated is visible in one style throughout. Names inside the generated code still come
-- from 'name / ''Name quotes, which resolve at *this* module's scope exactly as a quotation
-- bracket would, so nothing is lost to capture by dropping the brackets.
--
-- Two constructors resist this and stay as TH.Lib combinators, both for the same reason --
-- template-haskell changed their arity inside the GHC range this package supports (8.10's
-- 2.16 through 9.10's 2.22), so a literal application of either fails to compile on one end
-- or the other:
--   * ConP gained a [Type] field for visible type application in 2.18 (GHC 9.2) -- see conPat.
--   * TyVarBndr gained a flag parameter in 2.17, so PlainTV took a second argument -- hence
--     plainTV in deriveOptionsRecord.
--
-- Every generated top-level name (the merged ADTs, the mapper/ordinal/tenor functions, the
-- options record and its default value) goes through mkName rather than newName *by design*:
-- these are exactly the names the splice site then refers to by hand, so they must not be
-- freshened. newName is used only where it belongs -- pattern variables inside the generated
-- clauses, which nothing outside refers to.

-- the one non-portable Pat constructor, see the note above
conPat :: Name -> [Pat] -> Q Pat
conPat :: Name -> [Pat] -> Q Pat
conPat Name
n [Pat]
ps = Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
n ((Pat -> Q Pat) -> [Pat] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Pat -> Q Pat
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Pat]
ps)

arrowT :: Type -> Type -> Type
arrowT :: Type -> Type -> Type
arrowT Type
a = Type -> Type -> Type
AppT (Type -> Type -> Type
AppT Type
ArrowT Type
a)

pairT :: Type -> Type -> Type
pairT :: Type -> Type -> Type
pairT Type
a = Type -> Type -> Type
AppT (Type -> Type -> Type
AppT (Int -> Type
TupleT Int
2) Type
a)

-- TupE has taken [Maybe Exp] (for tuple sections) since template-haskell 2.16, i.e. across
-- the whole supported GHC range, so unlike ConP/PlainTV it needs no combinator
pairE :: Exp -> Exp -> Exp
pairE :: Exp -> Exp -> Exp
pairE Exp
a Exp
b = [Maybe Exp] -> Exp
TupE [Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
a, Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
b]

fromEnumE :: Exp -> Exp
fromEnumE :: Exp -> Exp
fromEnumE = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'fromEnum)

-- One data constructor of a reified plain data type, plus its argument types.
normalConstructor :: Con -> Q (Name, [BangType])
normalConstructor :: Con -> Q (Name, [BangType])
normalConstructor (NormalC Name
dCon [BangType]
dConArgs) = (Name, [BangType]) -> Q (Name, [BangType])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
dCon, [BangType]
dConArgs)
normalConstructor Con
c = String -> Q (Name, [BangType])
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Name, [BangType])) -> String -> Q (Name, [BangType])
forall a b. (a -> b) -> a -> b
$ String
"Unsupported constructor: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Con -> String
forall a. Show a => a -> String
show Con
c

-- An explicit case rather than a refutable `(TyConI (DataD ...)) <- reify x` pattern bind:
-- handing this a newtype, a type synonym or a class would otherwise fail in Q's MonadFail
-- with a "Pattern match failure" naming neither the argument nor what was actually found.
getConstructors :: Name -> Q [(Name, [BangType])] -- [(data constructor, constructor args)]
getConstructors :: Name -> Q [(Name, [BangType])]
getConstructors Name
x = Name -> Q Info
reify Name
x Q Info
-> (Info -> Q [(Name, [BangType])]) -> Q [(Name, [BangType])]
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  TyConI (DataD Cxt
_ Name
_tCon [TyVarBndr BndrVis]
_ Maybe Type
_ [Con]
dCons [DerivClause]
_) -> (Con -> Q (Name, [BangType])) -> [Con] -> Q [(Name, [BangType])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Con -> Q (Name, [BangType])
normalConstructor [Con]
dCons
  Info
info -> String -> Q [(Name, [BangType])]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q [(Name, [BangType])])
-> String -> Q [(Name, [BangType])]
forall a b. (a -> b) -> a -> b
$ String
"Expected a plain data declaration for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", got: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Info -> String
forall a. Show a => a -> String
show Info
info

-- what a main enum value's sub-choice looks like, once we go find the type named
-- <mainValue><subSuffix>: nothing there at all, a proper enum to cross-product with,
-- or just a `type X = Bool` marker (see the deriveCrossEnum comment below)
data SubKind = NoSub | EnumSub [Name] | BoolSub

classifySub :: String -> Q SubKind
classifySub :: String -> Q SubKind
classifySub String
d = String -> Q (Maybe Name)
lookupTypeName String
d Q (Maybe Name) -> (Maybe Name -> Q SubKind) -> Q SubKind
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Q SubKind -> (Name -> Q SubKind) -> Maybe Name -> Q SubKind
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (SubKind -> Q SubKind
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return SubKind
NoSub) (Name -> Q Info
reify (Name -> Q Info) -> (Info -> Q SubKind) -> Name -> Q SubKind
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Info -> Q SubKind
classify)
  where
    classify :: Info -> Q SubKind
classify (TyConI (DataD Cxt
_ Name
_ [TyVarBndr BndrVis]
_ Maybe Type
_ [Con]
dCons [DerivClause]
_)) = [Name] -> SubKind
EnumSub ([Name] -> SubKind)
-> ([(Name, [BangType])] -> [Name])
-> [(Name, [BangType])]
-> SubKind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Name, [BangType]) -> Name) -> [(Name, [BangType])] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, [BangType]) -> Name
forall a b. (a, b) -> a
fst ([(Name, [BangType])] -> SubKind)
-> Q [(Name, [BangType])] -> Q SubKind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Con -> Q (Name, [BangType])) -> [Con] -> Q [(Name, [BangType])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Con -> Q (Name, [BangType])
normalConstructor [Con]
dCons
    classify (TyConI (TySynD Name
_ [TyVarBndr BndrVis]
_ (ConT Name
b))) | Name
b Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Bool = SubKind -> Q SubKind
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return SubKind
BoolSub
    classify Info
info = String -> Q SubKind
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q SubKind) -> String -> Q SubKind
forall a b. (a -> b) -> a -> b
$ String
"deriveCrossEnum: unsupported sub-type declaration for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
d String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Info -> String
forall a. Show a => a -> String
show Info
info

-- Strips the "<Prefix>__" that a c2hs `add prefix = "Prefix__"` puts on every constructor of
-- a generated enum. Takes the Name rather than its nameBase purely so the failure can say
-- which constructor it choked on -- the type it came from isn't recoverable from a Name.
stripEnumPrefix :: Name -> String
stripEnumPrefix :: Name -> String
stripEnumPrefix Name
name = String -> String
go (Name -> String
nameBase Name
name)
  where
    go :: String -> String
go str :: String
str@(Char
_:String
cs)
      | String
"__" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
str = Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
2 String
str
      | Bool
otherwise = String -> String
go String
cs
    -- error, not fail: this is pure, called from pure positions (concatNames, dropIborSentinel).
    -- It still surfaces at compile time, since TH forces it while building the splice's output.
    go [] = String -> String
forall a. HasCallStack => String -> a
error (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"Expected a c2hs enum constructor carrying a \"Prefix__\" prefix, but "
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" has no __ separator"

-- The body baked into the catch-all clause of every generated dispatch function: those
-- functions map a constructor back to its C enum ordinal(s), which the "extra" constructors
-- (built from their own dedicated C shim) don't have. It's a bug if this ever fires, so the
-- message names the generated function that fired it.
unenumerableError :: String -> Body
unenumerableError :: String -> Body
unenumerableError String
fnName = Exp -> Body
NormalB (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'error) (Lit -> Exp
LitE (String -> Lit
StringL String
msg)))
  where msg :: String
msg = String
"Internal error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fnName String -> String -> String
forall a. [a] -> [a] -> [a]
++
              String
" called on a non-enumerable data constructor, probably an extra one"

-- merge a set of enums into a big one providing a function to map values back to ordinal numbers of original enums
-- e.g. for mainEnum data CalendarCountry = Country__Australia | Country__UnitedStated,
-- subEnum suffix "Market" and UnitedStatesMarket = UnitedStates__NYSE | UnitedStates__Settlement
-- NB I use prefixes separated from the main entry with underscore, in final enum they are stripped off
-- the function will build Australia | UnitedStatesNYSE | UnitedStatesSettlement
-- Calendar market choices are represented by a separate per-country type.
-- but too many country calendars contain Settlement and UnitedStates UnitedStatesSettlement
-- (or Actual365Fixed Actual365FixedStandard) looks really awful
--
-- for every main value I go look for a type named <mainValue><subSuffix>, and there are three
-- possible outcomes (classifySub above): nothing by that name -> plain nullary constructor, as
-- above; a real enum -> cross-product like above; or a `type <mainValue><subSuffix> = Bool`
-- synonym -> this main value doesn't have a fixed set of named sub-values at all, it just wraps
-- whatever Bool the caller passes in (e.g. Actual360's includeLastDay flag), so instead of picking
-- a named sub-constructor I give it a single constructor with a runtime Bool field. That's also why
-- caseClauses can't reuse enumVal's conE trick for these: enumVal grabs a sub-value that's fixed at
-- compile time (a named constructor), but a Bool only exists once someone calls the generated
-- constructor, so its clause has to bind a pattern variable and fromEnum that at runtime instead.
-- stripEnumPrefix doesn't need to know about any of this -- it's still only ever run on the
-- __-containing main enum name, never on the Bool value itself (True/False have no __ in them).
--
-- what comes out the other end (the three Decs returned below): a merged data type named
-- resName holding all of the above plus the extra constructors verbatim, and a mapper function
-- named mapper :: resName -> (Int, Int) that turns any of its non-extra constructors back into
-- (ordinal of the main value, ordinal of the sub value) -- that pair is exactly what the two-int
-- C dispatch functions (qlDayCounter, qlCalendar, ...) expect, so callers just go
-- `uncurry qlDayCounter $ mapDayCounter x`. Extra constructors have no such pair (they're built
-- from their own dedicated C shim instead), so mapper blows up on them via the defaultClause --
-- it's a bug if that ever actually fires.
-- A record rather than five positional arguments, for the same reason as IborConstructorSpec
-- below: resName/mapperFn/subSuffix are three interchangeable Strings and mainEnum/extraType
-- two interchangeable Names, so a transposition type-checks and silently generates the wrong
-- thing.
data CrossEnumSpec = CrossEnumSpec
  { CrossEnumSpec -> String
crossTypeName :: String   -- ^the merged ADT to generate
  , CrossEnumSpec -> String
crossMapperFn :: String   -- ^generated @\<ADT\> -> (Int, Int)@ main/sub ordinal pair
  , CrossEnumSpec -> Name
crossMainEnum :: Name     -- ^the main C enum
  , CrossEnumSpec -> String
crossSubSuffix :: String  -- ^appended to a stripped main value to find its sub-type
  , CrossEnumSpec -> Name
crossExtraType :: Name    -- ^data type holding the non-enumerable extra constructors
  }

deriveCrossEnum :: CrossEnumSpec -> DecsQ
deriveCrossEnum :: CrossEnumSpec -> DecsQ
deriveCrossEnum CrossEnumSpec
spec = do
  mainValues <- ((Name, [BangType]) -> Name) -> [(Name, [BangType])] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, [BangType]) -> Name
forall a b. (a, b) -> a
fst ([(Name, [BangType])] -> [Name])
-> Q [(Name, [BangType])] -> Q [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q [(Name, [BangType])]
getConstructors (CrossEnumSpec -> Name
crossMainEnum CrossEnumSpec
spec)

  mergedValues <- concat <$> mapM (\Name
d -> do -- (mainName, subName, []), the third member holds constructor arguments (extras, or a lone Bool for BoolSub)
    sub <- String -> Q SubKind
classifySub (Name -> String
stripEnumPrefix Name
d String -> String -> String
forall a. [a] -> [a] -> [a]
++ CrossEnumSpec -> String
crossSubSuffix CrossEnumSpec
spec)
    return $ case sub of
      SubKind
NoSub -> [(Name
d, Maybe Name
forall a. Maybe a
Nothing, [])]
      EnumSub [Name]
vals -> [Name]
-> [Maybe Name] -> [[BangType]] -> [(Name, Maybe Name, [BangType])]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 (Name -> [Name]
forall a. a -> [a]
repeat Name
d) ((Name -> Maybe Name) -> [Name] -> [Maybe Name]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Maybe Name
forall a. a -> Maybe a
Just [Name]
vals) ([BangType] -> [[BangType]]
forall a. a -> [a]
repeat [])
      SubKind
BoolSub -> [(Name
d, Maybe Name
forall a. Maybe a
Nothing, [(SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
SourceStrict, Name -> Type
ConT ''Bool)])]) mainValues

  extraConstructors <- map (\(Name
con, [BangType]
args) -> (Name
con, Maybe Name
forall a. Maybe a
Nothing, [BangType]
args)) <$> getConstructors (crossExtraType spec)

  caseClauses <- mapM mkClause mergedValues

  let defaultClause = [Pat] -> Body -> [Dec] -> Clause
Clause [Pat
WildP] (String -> Body
unenumerableError (CrossEnumSpec -> String
crossMapperFn CrossEnumSpec
spec)) []
      dataDecl = Cxt
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
resNameType [] Maybe Type
forall a. Maybe a
Nothing (((Name, Maybe Name, [BangType]) -> Con)
-> [(Name, Maybe Name, [BangType])] -> [Con]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
x, Maybe Name
y, [BangType]
a) -> Name -> [BangType] -> Con
NormalC (Name -> Maybe Name -> Name
concatNames Name
x Maybe Name
y) [BangType]
a) ([(Name, Maybe Name, [BangType])]
mergedValues [(Name, Maybe Name, [BangType])]
-> [(Name, Maybe Name, [BangType])]
-> [(Name, Maybe Name, [BangType])]
forall a. [a] -> [a] -> [a]
++ [(Name, Maybe Name, [BangType])]
extraConstructors)) []
      mapperSignature = Name -> Type -> Dec
SigD Name
mapperName (Type -> Type -> Type
arrowT (Name -> Type
ConT Name
resNameType) (Type -> Type -> Type
pairT (Name -> Type
ConT ''Int) (Name -> Type
ConT ''Int)))
      mapperBody = Name -> [Clause] -> Dec
FunD Name
mapperName ([Clause]
caseClauses [Clause] -> [Clause] -> [Clause]
forall a. [a] -> [a] -> [a]
++ [Clause
defaultClause])

  return [dataDecl, mapperSignature, mapperBody]

  where concatNames :: Name -> Maybe Name -> Name
        concatNames :: Name -> Maybe Name -> Name
concatNames Name
x Maybe Name
y = String -> Name
mkName (Name -> String
stripEnumPrefix Name
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> (Name -> String) -> Maybe Name -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" Name -> String
stripEnumPrefix Maybe Name
y)
        resNameType :: Name
resNameType = String -> Name
mkName (CrossEnumSpec -> String
crossTypeName CrossEnumSpec
spec)
        mapperName :: Name
mapperName = String -> Name
mkName (CrossEnumSpec -> String
crossMapperFn CrossEnumSpec
spec)
        enumVal :: Maybe Name -> Exp
        enumVal :: Maybe Name -> Exp
enumVal Maybe Name
Nothing = Lit -> Exp
LitE (Integer -> Lit
IntegerL Integer
0)
        enumVal (Just Name
n) = Exp -> Exp
fromEnumE (Name -> Exp
ConE Name
n)
        mkClause :: (Name, Maybe Name, [BangType]) -> Q Clause
        mkClause :: (Name, Maybe Name, [BangType]) -> Q Clause
mkClause (Name
mainVal, Maybe Name
subVal, []) = do
          pat <- Name -> [Pat] -> Q Pat
conPat (Name -> Maybe Name -> Name
concatNames Name
mainVal Maybe Name
subVal) []
          return $ Clause [pat] (NormalB (pairE (fromEnumE (ConE mainVal)) (enumVal subVal))) []
        mkClause (Name
mainVal, Maybe Name
Nothing, [BangType
_]) = do
          x <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
          pat <- conPat (concatNames mainVal Nothing) [VarP x]
          return $ Clause [pat] (NormalB (pairE (fromEnumE (ConE mainVal)) (fromEnumE (VarE x)))) []
        mkClause (Name
mainVal, Maybe Name
_, [BangType]
_) = String -> Q Clause
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Clause) -> String -> Q Clause
forall a b. (a -> b) -> a -> b
$ String
"deriveCrossEnum: unsupported sub-choice shape for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
mainVal

-- Unlike deriveCrossEnum's cross-product of two ordinal dimensions (a main enum times a
-- per-value sub-enum/bool), this concatenates several *sibling* enums -- normalEnum,
-- dailyEnum, onEnum -- each of which contributes one fixed constructor "shape" to a single
-- merged ADT, plus one flat Int dispatch ordinal per value (their positions in the shared
-- flat C array), computed here in Haskell rather than trusted from the C side. The three
-- enums are each independent, plain, zero-based C enums (no cross-enum value chaining); the
-- first two may carry a trailing sentinel constructor whose stripped name ends in "Last"
-- (e.g. IborIndexTypeLast), which exists purely as an "insert real values above this line"
-- marker in the C header and is dropped here via dropIborSentinel -- both to exclude it from
-- the merged ADT and so its group's real (sentinel-excluded) length becomes the next group's
-- ordinal offset, with no count ever hand-written on either side of the FFI boundary.
data IborShape = ShapeTenor | ShapeDailyTenor | ShapeOvernight

dropIborSentinel :: [(Name, [BangType])] -> [(Name, [BangType])]
dropIborSentinel :: [(Name, [BangType])] -> [(Name, [BangType])]
dropIborSentinel = ((Name, [BangType]) -> Bool)
-> [(Name, [BangType])] -> [(Name, [BangType])]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((Name, [BangType]) -> Bool) -> (Name, [BangType]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"Last" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf`) (String -> Bool)
-> ((Name, [BangType]) -> String) -> (Name, [BangType]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
stripEnumPrefix (Name -> String)
-> ((Name, [BangType]) -> Name) -> (Name, [BangType]) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, [BangType]) -> Name
forall a b. (a, b) -> a
fst)

-- A record rather than seven positional arguments: three Strings followed by four Names meant
-- any two same-typed arguments could be transposed with nothing to catch it -- swapping the
-- ordinal and tenor function names, or the daily-tenor and overnight enums, type-checks
-- silently and yields wrong-but-compiling generated code.
data IborConstructorSpec = IborConstructorSpec
  { IborConstructorSpec -> String
iborTypeName :: String        -- ^the merged ADT to generate
  , IborConstructorSpec -> String
iborOrdinalFn :: String       -- ^generated @\<ADT\> -> Int@ flat C dispatch ordinal
  , IborConstructorSpec -> String
iborTenorFn :: String         -- ^generated @\<ADT\> -> (Word, TimeUnit)@ tenor accessor
  , IborConstructorSpec -> Name
iborTenorEnum :: Name         -- ^C enum of the tenor-carrying indices
  , IborConstructorSpec -> Name
iborDailyTenorEnum :: Name    -- ^C enum of the daily-tenor indices
  , IborConstructorSpec -> Name
iborOvernightEnum :: Name     -- ^C enum of the overnight indices
  , IborConstructorSpec -> Name
iborExtraType :: Name         -- ^data type holding the non-enum-ordinal extra constructors
  }

deriveIborConstructor :: IborConstructorSpec -> DecsQ
deriveIborConstructor :: IborConstructorSpec -> DecsQ
deriveIborConstructor IborConstructorSpec
spec = do
  normalCtors <- [(Name, [BangType])] -> [(Name, [BangType])]
dropIborSentinel ([(Name, [BangType])] -> [(Name, [BangType])])
-> Q [(Name, [BangType])] -> Q [(Name, [BangType])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q [(Name, [BangType])]
getConstructors (IborConstructorSpec -> Name
iborTenorEnum IborConstructorSpec
spec)
  dailyCtors <- dropIborSentinel <$> getConstructors (iborDailyTenorEnum spec)
  onCtors <- dropIborSentinel <$> getConstructors (iborOvernightEnum spec)

  -- resolved against the splice site's scope (InterestRate.chs, where TimeUnit(..) and Days
  -- are already imported/in scope), not this module's own imports -- Syntax.hs must not import
  -- QuantLib.Time.Schedule directly, since Schedule -> CalendarEnum -> Syntax already, and that
  -- would close an import cycle
  timeUnit <- lookupTypeName "TimeUnit" >>= maybe (fail "deriveIborConstructor: TimeUnit not in scope at splice site") return
  days <- lookupValueName "Days" >>= maybe (fail "deriveIborConstructor: Days not in scope at splice site") return

  let dailyOffset = [(Name, [BangType])] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Name, [BangType])]
normalCtors
      onOffset = Int
dailyOffset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [(Name, [BangType])] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Name, [BangType])]
dailyCtors

  normalGroups <- mapM (mkGroup ShapeTenor timeUnit days 0) normalCtors
  dailyGroups <- mapM (mkGroup ShapeDailyTenor timeUnit days dailyOffset) dailyCtors
  onGroups <- mapM (mkGroup ShapeOvernight timeUnit days onOffset) onCtors

  extraConstructors <- getConstructors (iborExtraType spec)

  let extraCon (Name
con, [BangType]
args) = Name -> [BangType] -> Con
NormalC (String -> Name
mkName (Name -> String
stripEnumPrefix Name
con)) [BangType]
args
      ordinalDefault = [Pat] -> Body -> [Dec] -> Clause
Clause [Pat
WildP] (String -> Body
unenumerableError (IborConstructorSpec -> String
iborOrdinalFn IborConstructorSpec
spec)) []
      tenorDefault = [Pat] -> Body -> [Dec] -> Clause
Clause [Pat
WildP] (String -> Body
unenumerableError (IborConstructorSpec -> String
iborTenorFn IborConstructorSpec
spec)) []
      groups = [(Con, Clause, Clause)]
normalGroups [(Con, Clause, Clause)]
-> [(Con, Clause, Clause)] -> [(Con, Clause, Clause)]
forall a. [a] -> [a] -> [a]
++ [(Con, Clause, Clause)]
dailyGroups [(Con, Clause, Clause)]
-> [(Con, Clause, Clause)] -> [(Con, Clause, Clause)]
forall a. [a] -> [a] -> [a]
++ [(Con, Clause, Clause)]
onGroups
      dataDecl = Cxt
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
resNameType [] Maybe Type
forall a. Maybe a
Nothing
                   (((Con, Clause, Clause) -> Con) -> [(Con, Clause, Clause)] -> [Con]
forall a b. (a -> b) -> [a] -> [b]
map (\(Con
con, Clause
_, Clause
_) -> Con
con) [(Con, Clause, Clause)]
groups [Con] -> [Con] -> [Con]
forall a. [a] -> [a] -> [a]
++ ((Name, [BangType]) -> Con) -> [(Name, [BangType])] -> [Con]
forall a b. (a -> b) -> [a] -> [b]
map (Name, [BangType]) -> Con
extraCon [(Name, [BangType])]
extraConstructors) []
      ordinalSig = Name -> Type -> Dec
SigD Name
ordinalName (Type -> Type -> Type
arrowT (Name -> Type
ConT Name
resNameType) (Name -> Type
ConT ''Int))
      tenorSig = Name -> Type -> Dec
SigD Name
tenorName (Type -> Type -> Type
arrowT (Name -> Type
ConT Name
resNameType) (Type -> Type -> Type
pairT (Name -> Type
ConT ''Word) (Name -> Type
ConT Name
timeUnit)))
      ordinalBody = Name -> [Clause] -> Dec
FunD Name
ordinalName (((Con, Clause, Clause) -> Clause)
-> [(Con, Clause, Clause)] -> [Clause]
forall a b. (a -> b) -> [a] -> [b]
map (\(Con
_, Clause
o, Clause
_) -> Clause
o) [(Con, Clause, Clause)]
groups [Clause] -> [Clause] -> [Clause]
forall a. [a] -> [a] -> [a]
++ [Clause
ordinalDefault])
      tenorBody = Name -> [Clause] -> Dec
FunD Name
tenorName (((Con, Clause, Clause) -> Clause)
-> [(Con, Clause, Clause)] -> [Clause]
forall a b. (a -> b) -> [a] -> [b]
map (\(Con
_, Clause
_, Clause
t) -> Clause
t) [(Con, Clause, Clause)]
groups [Clause] -> [Clause] -> [Clause]
forall a. [a] -> [a] -> [a]
++ [Clause
tenorDefault])

  return [dataDecl, ordinalSig, ordinalBody, tenorSig, tenorBody]

  where
    resNameType :: Name
resNameType = String -> Name
mkName (IborConstructorSpec -> String
iborTypeName IborConstructorSpec
spec)
    ordinalName :: Name
ordinalName = String -> Name
mkName (IborConstructorSpec -> String
iborOrdinalFn IborConstructorSpec
spec)
    tenorName :: Name
tenorName = String -> Name
mkName (IborConstructorSpec -> String
iborTenorFn IborConstructorSpec
spec)

    mkGroup :: IborShape -> Name -> Name -> Int -> (Name, [BangType]) -> Q (Con, Clause, Clause)
    mkGroup :: IborShape
-> Name
-> Name
-> Int
-> (Name, [BangType])
-> Q (Con, Clause, Clause)
mkGroup IborShape
shape Name
timeUnit Name
days Int
offset (Name
origName, [BangType]
_) = do
      let strippedName :: Name
strippedName = String -> Name
mkName (Name -> String
stripEnumPrefix Name
origName)
          ordinalBody' :: Body
ordinalBody' = Exp -> Body
NormalB (Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Lit -> Exp
LitE (Integer -> Lit
IntegerL (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
offset)))) (Name -> Exp
VarE '(+))
                                         (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Exp
fromEnumE (Name -> Exp
ConE Name
origName))))
      case IborShape
shape of
        IborShape
ShapeTenor -> do
          let con :: Con
con = Name -> [BangType] -> Con
NormalC Name
strippedName
                [(SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
SourceStrict, Type -> Type -> Type
pairT (Name -> Type
ConT ''Word) (Name -> Type
ConT Name
timeUnit))]
          ordinalPat <- Name -> [Pat] -> Q Pat
conPat Name
strippedName [Pat
WildP]
          p <- newName "p"
          tenorPat <- conPat strippedName [VarP p]
          return (con, Clause [ordinalPat] ordinalBody' [], Clause [tenorPat] (NormalB (VarE p)) [])
        IborShape
ShapeDailyTenor -> do
          let con :: Con
con = Name -> [BangType] -> Con
NormalC Name
strippedName [(SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
SourceStrict, Name -> Type
ConT ''Word)]
          ordinalPat <- Name -> [Pat] -> Q Pat
conPat Name
strippedName [Pat
WildP]
          d <- newName "d"
          tenorPat <- conPat strippedName [VarP d]
          return ( con
                 , Clause [ordinalPat] ordinalBody' []
                 , Clause [tenorPat] (NormalB (pairE (VarE d) (ConE days))) [] )
        IborShape
ShapeOvernight -> do
          let con :: Con
con = Name -> [BangType] -> Con
NormalC Name
strippedName []
          pat <- Name -> [Pat] -> Q Pat
conPat Name
strippedName []
          return ( con
                 , Clause [pat] ordinalBody' []
                 , Clause [pat] (NormalB (pairE (LitE (IntegerL 0)) (ConE days))) [] )

-- A wide C++ constructor's trailing, upstream-defaulted params are turned into
-- one record type (one field per param, in the order given) plus a `default<recName>`
-- value built from the supplied default exprs. Unlike deriveCrossEnum/deriveIborConstructor,
-- this deliberately does NOT reify the target binding's type to recover field types --
-- doing so for a c2hs-generated function whose distinct trailing params can each carry
-- their own independent type variable (e.g. OISRateHelper's fixedRate :: GenQuote a vs.
-- overnightSpread :: Maybe (GenQuote m)) would mean decomposing a ForallT, working out
-- which of its bound variables occur free in just the trailing slice, and re-quantifying
-- the generated record/wrapper over exactly those -- real complexity with no precedent
-- elsewhere in this module (both existing helpers only reify enum/data-constructor
-- *shapes*, never a function's type). Taking explicit field types (and, since a field's
-- type may itself mention a fresh type variable, the record's own type parameters) at
-- the splice site sidesteps all of that; the actual drift protection this exists for --
-- "the record's fields must match the underlying binding" -- still comes for free from
-- the type checker at the hand-written wrapper that applies the record's fields to that
-- binding, so nothing is lost by not reifying.
deriveOptionsRecord :: String -> [String] -> [(String, TypeQ, ExpQ)] -> DecsQ
deriveOptionsRecord :: String -> [String] -> [(String, TypeQ, ExpQ)] -> DecsQ
deriveOptionsRecord String
recName [String]
tyVarNames [(String, TypeQ, ExpQ)]
fields = do
  -- the field types and default exprs are the caller's own Q values, so unlike the two
  -- functions above these have to be run before the raw Decs can be assembled
  fieldTypes <- [TypeQ] -> Q Cxt
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [TypeQ
t | (String
_, TypeQ
t, ExpQ
_) <- [(String, TypeQ, ExpQ)]
fields]
  fieldDefaults <- sequence [e | (_, _, e) <- fields]

  let tyVars = (String -> TyVarBndr BndrVis) -> [String] -> [TyVarBndr BndrVis]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> TyVarBndr BndrVis
forall flag. DefaultBndrFlag flag => Name -> TyVarBndr flag
plainTV (Name -> TyVarBndr BndrVis)
-> (String -> Name) -> String -> TyVarBndr BndrVis
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName) [String]
tyVarNames
      recFields = (Name -> Type -> (Name, Bang, Type))
-> [Name] -> Cxt -> [(Name, Bang, Type)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Name
n Type
t -> (Name
n, Bang
strictness, Type
t)) [Name]
fieldNames Cxt
fieldTypes
  return
    [ DataD [] recTypeName tyVars Nothing [RecC recTypeName recFields] []
    , SigD defaultName (foldl AppT (ConT recTypeName) (map (VarT . mkName) tyVarNames))
    , FunD defaultName [Clause [] (NormalB (RecConE recTypeName (zip fieldNames fieldDefaults))) []]
    ]
  where
    recTypeName :: Name
recTypeName = String -> Name
mkName String
recName
    defaultName :: Name
defaultName = String -> Name
mkName (String
"default" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
camelInitialism String
recName)
    fieldNames :: [Name]
fieldNames = [String -> Name
mkName String
n | (String
n, TypeQ
_, ExpQ
_) <- [(String, TypeQ, ExpQ)]
fields]
    -- lazy fields, unlike the strict (!) ones the two enum-merging functions above generate
    strictness :: Bang
strictness = SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness

-- Camel-case a leading acronym while leaving the type name itself alone:
-- OISRateHelperOpts becomes the default-value stem OisRateHelperOpts, while
-- IborLegOpts remains IborLegOpts.
camelInitialism :: String -> String
camelInitialism :: String -> String
camelInitialism [] = []
camelInitialism String
name =
  case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isUpper String
name of
    ([], String
_) -> String
name
    ([Char
c], String
rest) -> Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
rest
    (Char
first : String
more, []) -> Char
first Char -> String -> String
forall a. a -> [a] -> [a]
: (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
more
    (Char
first : String
more, String
rest) ->
      case String -> String
forall a. [a] -> [a]
reverse String
more of
        Char
boundary : String
reversedMiddle ->
          Char
first Char -> String -> String
forall a. a -> [a] -> [a]
: ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> String
forall a. [a] -> [a]
reverse String
reversedMiddle) String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char
boundary Char -> String -> String
forall a. a -> [a] -> [a]
: String
rest))
        [] -> Char
first Char -> String -> String
forall a. a -> [a] -> [a]
: String
rest

-- A merged ADT from deriveCrossEnum/deriveIborConstructor can't get a plain `deriving
-- (Read)` when any of its "extra" constructors carries a live QuantLib object (Calendar,
-- Currency, DayCounter, Schedule -- see the newtype declarations in QuantLib.Internal.Type):
-- those are opaque ForeignPtr handles with no Read instance and no realistic way to acquire
-- one, and GHC's stock deriving needs Read for every field type across *every* constructor
-- of the type, not just the ones actually being parsed.
--
-- This generates a plain `Int -> ReadS <targetTy>` function, *not* a `Read` instance, that
-- covers every constructor whose fields are all directly Read (every deriveCrossEnum
-- cross-product tag, every BoolSub case, and any "extra" constructor with no live-object
-- field -- Bespoke, for CalendarConstructor). Constructors with a
-- Calendar/Currency/DayCounter/Schedule field are left out entirely: the actual `Read
-- <targetTy>` instance is hand-written at the splice site that has the live-object
-- materializer in scope (`calendar`/`currency`/`dayCounter`), as this generated function's
-- alternatives `++`-ed with one hand-written alternative per proxy-backed live field, e.g.
--   instance Read CalendarConstructor where
--     readsPrec d r = readCalendarConstructorPlain d r
--       ++ readParen (d > 10) (\r' -> [(Joint2 c1 c2 rule, s3)
--            | ("Joint2", s0) <- lex r', (p1, s1) <- readsPrec 11 s0
--            , let c1 = unsafePerformIO (calendar p1), (p2, s2) <- readsPrec 11 s1
--            , let c2 = unsafePerformIO (calendar p2), (rule, s3) <- readsPrec 11 s2]) r
-- (`unsafePerformIO` here mirrors `Show Calendar`/`Show Currency`/`Show DayCounter`'s own
-- `showStandalone`, `QuantLib/Internal/Type.hs` -- calling into C++ from pure code is already
-- this codebase's idiom for these types, and the shim functions underneath already catch
-- `std::exception` and turn it into an ordinary `throwIO`, `errorCheck` in
-- `QuantLib/Internal.hs`, so no raw C++ exception crosses it.) Skipping
-- ActualActualBond'/ActualActualISMA' (Schedule fields, no readable proxy at all) from
-- DayCounterConstructor's hand-written instance leaves them permanently unparseable by
-- design: no alternative means `read`/`reads` falls through to the standard "no parse".
--
-- Generate only the parser function here and define the instance beside its materializers.
-- c2hs emits foreign stubs at the physical end of a file, so a TH splice after any `{#fun#}`
-- separates wrappers from their stubs; Calendar and Schedule also import CalendarEnum, ruling out
-- moving the instance there without a cycle.
liveObjectTypeNames :: [String]
liveObjectTypeNames :: [String]
liveObjectTypeNames = [String
"Calendar", String
"Currency", String
"DayCounter", String
"Schedule"]

isDirectlyReadable :: Type -> Bool
isDirectlyReadable :: Type -> Bool
isDirectlyReadable (ConT Name
n) = Name -> String
nameBase Name
n String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String]
liveObjectTypeNames
isDirectlyReadable Type
_ = Bool
True

deriveReadPlain :: String -> Name -> DecsQ
deriveReadPlain :: String -> Name -> DecsQ
deriveReadPlain String
fnName Name
targetTy = do
  cons <- Name -> Q [(Name, [BangType])]
getConstructors Name
targetTy
  let readableCons = [(Name
con, (BangType -> Type) -> [BangType] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Type
forall a b. (a, b) -> b
snd [BangType]
args) | (Name
con, [BangType]
args) <- [(Name, [BangType])]
cons, (BangType -> Bool) -> [BangType] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Type -> Bool
isDirectlyReadable (Type -> Bool) -> (BangType -> Type) -> BangType -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BangType -> Type
forall a b. (a, b) -> b
snd) [BangType]
args]
  d <- newName "d"
  r <- newName "r"
  alts <- mapM (mkAlt d) readableCons
  let appliedAlts = [Exp -> Exp -> Exp
AppE Exp
a (Name -> Exp
VarE Name
r) | Exp
a <- [Exp]
alts]
      body = case [Exp]
appliedAlts of
        [] -> [Exp] -> Exp
ListE []
        (Exp
a0:[Exp]
as) -> (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Exp
acc Exp
x -> Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
acc) (Name -> Exp
VarE '(++)) (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
x)) Exp
a0 [Exp]
as
      resultTy = Type -> Type -> Type
AppT Type
ListT (Type -> Type -> Type
pairT (Name -> Type
ConT Name
targetTy) (Name -> Type
ConT ''String))
      sig = Name -> Type -> Dec
SigD Name
fn (Type -> Type -> Type
arrowT (Name -> Type
ConT ''Int) (Type -> Type -> Type
arrowT (Name -> Type
ConT ''String) Type
resultTy))
      def = Name -> [Clause] -> Dec
FunD Name
fn [[Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Pat
VarP Name
d, Name -> Pat
VarP Name
r] (Exp -> Body
NormalB Exp
body) []]
  return [sig, def]
  where
    fn :: Name
fn = String -> Name
mkName String
fnName
    appPrec :: Integer
appPrec = Integer
10 :: Integer

    mkAlt :: Name -> (Name, [Type]) -> Q Exp
    mkAlt :: Name -> (Name, Cxt) -> ExpQ
mkAlt Name
d (Name
con, Cxt
tys) = do
      r0 <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"r0"
      r1 <- newName "r1"
      let lexStmt = Pat -> Exp -> Stmt
BindS ([Pat] -> Pat
TupP [Lit -> Pat
LitP (String -> Lit
StringL (Name -> String
nameBase Name
con)), Name -> Pat
VarP Name
r1]) (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'lex) (Name -> Exp
VarE Name
r0))
      (fieldStmts, xs, sLast) <- foldFields r1 tys
      let yieldExp = Exp -> Exp -> Exp
pairE ((Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
AppE (Name -> Exp
ConE Name
con) ((Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE [Name]
xs)) (Name -> Exp
VarE Name
sLast)
          comp = [Stmt] -> Exp
CompE (Stmt
lexStmt Stmt -> [Stmt] -> [Stmt]
forall a. a -> [a] -> [a]
: [Stmt]
fieldStmts [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ [Exp -> Stmt
NoBindS Exp
yieldExp])
          lam = [Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
r0] Exp
comp
          cond | Cxt -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Cxt
tys = Name -> Exp
ConE 'False
               | Bool
otherwise = Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Name -> Exp
VarE Name
d)) (Name -> Exp
VarE '(>)) (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Lit -> Exp
LitE (Integer -> Lit
IntegerL Integer
appPrec)))
      return (AppE (AppE (VarE 'readParen) cond) lam)

    -- threads the "remaining input" variable through one readsPrec call per field, returning
    -- the field-binding Stmts, the Names holding each field's parsed value (in order), and
    -- the Name holding what's left of the input.
    foldFields :: Name -> [Type] -> Q ([Stmt], [Name], Name)
    foldFields :: Name -> Cxt -> Q ([Stmt], [Name], Name)
foldFields Name
cur [] = ([Stmt], [Name], Name) -> Q ([Stmt], [Name], Name)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [], Name
cur)
    foldFields Name
cur (Type
_:Cxt
tys) = do
      x <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
      sNext <- newName "s"
      let readStmt = Pat -> Exp -> Stmt
BindS ([Pat] -> Pat
TupP [Name -> Pat
VarP Name
x, Name -> Pat
VarP Name
sNext])
                           (Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'readsPrec) (Lit -> Exp
LitE (Integer -> Lit
IntegerL (Integer
appPrec Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1)))) (Name -> Exp
VarE Name
cur))
      (restStmts, restXs, finalS) <- foldFields sNext tys
      return (readStmt : restStmts, x : restXs, finalS)

-- Generates a *full* `Read <targetTy>` instance in one splice, unlike deriveReadPlain above
-- (whose function still needs a hand-written instance layered on top elsewhere). This is only
-- legal where deriveReadPlain's comment says a splice is safe (before any `{#fun#}` pragma in
-- the file, or none at all) *and* the field materializers named in `table` (e.g. `[("Calendar",
-- 'calendar)]`) already live in other, separately-compiled modules -- so this file isn't the
-- one closing an import cycle by needing them. IborConstructor (spliced from
-- QuantLib.Index.InterestRate, before that file's first `{#fun#}`, needing
-- `calendar`/`currency`/`dayCounter` from three *other* already-compiled modules) is the one
-- user of this today; CalendarConstructor/DayCounterConstructor can't use it precisely because
-- their materializers are declared in modules that import CalendarEnum back.
--
-- A field whose type name is in `table` is parsed as its proxy type and materialized via a
-- generated top-level `unsafe<Fn>` binding (`unsafeCalendar = unsafePerformIO . calendar`,
-- etc, one per distinct materializer, each NOINLINE for the same reason as
-- `showStandalone`/the hand-written `unsafeCalendar`s in Calendar.chs/Schedule.chs). A field
-- whose type name is in `liveObjectTypeNames` but not `table` (or any other live type this
-- table doesn't cover) makes its whole constructor unparseable, exactly as in deriveReadPlain.
deriveReadInstance :: Name -> [(String, Name)] -> DecsQ
deriveReadInstance :: Name -> [(String, Name)] -> DecsQ
deriveReadInstance Name
targetTy [(String, Name)]
table = do
  cons <- Name -> Q [(Name, [BangType])]
getConstructors Name
targetTy
  d <- newName "d"
  r <- newName "r"
  altsMaybe <- mapM (\(Name
con, [BangType]
args) -> Name -> Cxt -> Name -> Q (Maybe Exp)
mkAlt Name
d ((BangType -> Type) -> [BangType] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Type
forall a b. (a, b) -> b
snd [BangType]
args) Name
con) cons
  wrapperDecs <- concat <$> mapM mkWrapper (nubNames (map snd table))
  let alts = [Maybe Exp] -> [Exp]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Exp]
altsMaybe
      appliedAlts = [Exp -> Exp -> Exp
AppE Exp
a (Name -> Exp
VarE Name
r) | Exp
a <- [Exp]
alts]
      body = case [Exp]
appliedAlts of
        [] -> [Exp] -> Exp
ListE []
        (Exp
a0:[Exp]
as) -> (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Exp
acc Exp
x -> Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
acc) (Name -> Exp
VarE '(++)) (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
x)) Exp
a0 [Exp]
as
      readsPrecDec = Name -> [Clause] -> Dec
FunD 'readsPrec [[Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Pat
VarP Name
d, Name -> Pat
VarP Name
r] (Exp -> Body
NormalB Exp
body) []]
      instanceDec = Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [] (Type -> Type -> Type
AppT (Name -> Type
ConT ''Read) (Name -> Type
ConT Name
targetTy)) [Dec
readsPrecDec]
  return (wrapperDecs ++ [instanceDec])
  where
    appPrec :: Integer
appPrec = Integer
10 :: Integer

    nubNames :: [Name] -> [Name]
nubNames = (Name -> [Name] -> [Name]) -> [Name] -> [Name] -> [Name]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Name
n [Name]
acc -> if Name
n Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
acc then [Name]
acc else Name
n Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
acc) []

    wrapperName :: Name -> Name
    wrapperName :: Name -> Name
wrapperName Name
fn = String -> Name
mkName (String
"unsafe" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
capitalize (Name -> String
nameBase Name
fn))
      where capitalize :: String -> String
capitalize (Char
c:String
cs) = Char -> Char
toUpper Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
cs
            capitalize [] = []

    -- reifies `fn :: <proxy> -> IO <live>` to give the generated `unsafe<Fn>` wrapper an
    -- explicit signature (a bare `deriving`-adjacent, unsigned top-level binding would trip
    -- -Wmissing-signatures) without having to thread the proxy type's own Name through
    -- `table` -- `table` only ever needs to name the materializer, this recovers its type.
    mkWrapper :: Name -> Q [Dec]
    mkWrapper :: Name -> DecsQ
mkWrapper Name
fn = do
      (dom, cod) <- Name -> Q (Type, Type)
reifyFnType Name
fn
      let wname = Name -> Name
wrapperName Name
fn
      return
        [ SigD wname (arrowT dom cod)
        , FunD wname [Clause [] (NormalB (InfixE (Just (VarE 'unsafePerformIO)) (VarE '(.)) (Just (VarE fn)))) []]
        , PragmaD (InlineP wname NoInline FunLike AllPhases)
        ]

    reifyFnType :: Name -> Q (Type, Type)
    reifyFnType :: Name -> Q (Type, Type)
reifyFnType Name
fn = Name -> Q Info
reify Name
fn Q Info -> (Info -> Q (Type, Type)) -> Q (Type, Type)
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      VarI Name
_ (AppT (AppT Type
ArrowT Type
dom) (AppT (ConT Name
io) Type
cod)) Maybe Dec
_ | Name
io Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''IO -> (Type, Type) -> Q (Type, Type)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
dom, Type
cod)
      Info
info -> String -> Q (Type, Type)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Type, Type)) -> String -> Q (Type, Type)
forall a b. (a -> b) -> a -> b
$ String
"deriveReadInstance: expected `<proxy> -> IO <live>` for "
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
fn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", got: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Info -> String
forall a. Show a => a -> String
show Info
info

    classifyReadField :: Type -> Maybe FieldReadPlan
    classifyReadField :: Type -> Maybe FieldReadPlan
classifyReadField (ConT Name
n)
      | Just Name
fn <- String -> [(String, Name)] -> Maybe Name
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Name -> String
nameBase Name
n) [(String, Name)]
table = FieldReadPlan -> Maybe FieldReadPlan
forall a. a -> Maybe a
Just (Name -> FieldReadPlan
ReadViaProxy Name
fn)
      | Name -> String
nameBase Name
n String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
liveObjectTypeNames = Maybe FieldReadPlan
forall a. Maybe a
Nothing
    classifyReadField Type
_ = FieldReadPlan -> Maybe FieldReadPlan
forall a. a -> Maybe a
Just FieldReadPlan
ReadDirect

    mkAlt :: Name -> [Type] -> Name -> Q (Maybe Exp)
    mkAlt :: Name -> Cxt -> Name -> Q (Maybe Exp)
mkAlt Name
d Cxt
tys Name
con = case (Type -> Maybe FieldReadPlan) -> Cxt -> Maybe [FieldReadPlan]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type -> Maybe FieldReadPlan
classifyReadField Cxt
tys of
      Maybe [FieldReadPlan]
Nothing -> Maybe Exp -> Q (Maybe Exp)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Exp
forall a. Maybe a
Nothing
      Just [FieldReadPlan]
plans -> do
          r0 <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"r0"
          r1 <- newName "r1"
          let lexStmt = Pat -> Exp -> Stmt
BindS ([Pat] -> Pat
TupP [Lit -> Pat
LitP (String -> Lit
StringL (Name -> String
nameBase Name
con)), Name -> Pat
VarP Name
r1]) (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'lex) (Name -> Exp
VarE Name
r0))
          (fieldStmts, xs, sLast) <- foldFieldsProxy r1 plans
          let yieldExp = Exp -> Exp -> Exp
pairE ((Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
AppE (Name -> Exp
ConE Name
con) ((Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE [Name]
xs)) (Name -> Exp
VarE Name
sLast)
              comp = [Stmt] -> Exp
CompE (Stmt
lexStmt Stmt -> [Stmt] -> [Stmt]
forall a. a -> [a] -> [a]
: [Stmt]
fieldStmts [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ [Exp -> Stmt
NoBindS Exp
yieldExp])
              lam = [Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
r0] Exp
comp
              cond | Cxt -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Cxt
tys = Name -> Exp
ConE 'False
                   | Bool
otherwise = Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Name -> Exp
VarE Name
d)) (Name -> Exp
VarE '(>)) (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Lit -> Exp
LitE (Integer -> Lit
IntegerL Integer
appPrec)))
          return (Just (AppE (AppE (VarE 'readParen) cond) lam))

    -- like deriveReadPlain's foldFields, but a ReadViaProxy field also materializes the
    -- parsed proxy value via the field's generated `unsafe<Fn>` wrapper.
    foldFieldsProxy :: Name -> [FieldReadPlan] -> Q ([Stmt], [Name], Name)
    foldFieldsProxy :: Name -> [FieldReadPlan] -> Q ([Stmt], [Name], Name)
foldFieldsProxy Name
cur [] = ([Stmt], [Name], Name) -> Q ([Stmt], [Name], Name)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [], Name
cur)
    foldFieldsProxy Name
cur (FieldReadPlan
p:[FieldReadPlan]
ps) = do
      xRaw <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
      sNext <- newName "s"
      let readStmt = Pat -> Exp -> Stmt
BindS ([Pat] -> Pat
TupP [Name -> Pat
VarP Name
xRaw, Name -> Pat
VarP Name
sNext])
                           (Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'readsPrec) (Lit -> Exp
LitE (Integer -> Lit
IntegerL (Integer
appPrec Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1)))) (Name -> Exp
VarE Name
cur))
      case p of
        FieldReadPlan
ReadDirect -> do
          (restStmts, restXs, finalS) <- Name -> [FieldReadPlan] -> Q ([Stmt], [Name], Name)
foldFieldsProxy Name
sNext [FieldReadPlan]
ps
          return (readStmt : restStmts, xRaw : restXs, finalS)
        ReadViaProxy Name
fn -> do
          xVal <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
          let letStmt = [Dec] -> Stmt
LetS [Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP Name
xVal) (Exp -> Body
NormalB (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE (Name -> Name
wrapperName Name
fn)) (Name -> Exp
VarE Name
xRaw))) []]
          (restStmts, restXs, finalS) <- foldFieldsProxy sNext ps
          return (readStmt : letStmt : restStmts, xVal : restXs, finalS)

data FieldReadPlan = ReadDirect | ReadViaProxy Name

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