├── Setup.hs ├── doc ├── minus.gif ├── plus.gif ├── synopsis.png ├── hslogo-16.png ├── mini_CalendarTest.html ├── mini_Credit.html ├── frames.html ├── CalendarTest.html ├── mini_Swaps.html ├── index-frames.html ├── index.html ├── doc-index.html ├── doc-index-H.html ├── doc-index-60.html ├── mini_Calendar.html ├── doc-index-Y.html ├── doc-index-K.html ├── doc-index-Q.html ├── doc-index-W.html ├── Credit.html ├── doc-index-Z.html ├── doc-index-G.html ├── doc-index-V.html ├── doc-index-R.html ├── doc-index-O.html ├── doc-index-L.html ├── doc-index-I.html ├── doc-index-U.html ├── mini_Options.html ├── doc-index-F.html ├── doc-index-T.html ├── doc-index-N.html ├── doc-index-B.html ├── doc-index-M.html ├── doc-index-37.html ├── doc-index-E.html ├── doc-index-S.html ├── doc-index-A.html ├── doc-index-D.html ├── doc-index-P.html ├── mini_Contract.html ├── mini_Pricing.html ├── mini_Observable.html └── doc-index-C.html ├── share ├── Calendar.o ├── Common.hi ├── Common.o ├── Calendar.hi ├── Settlement.hs ├── normalise-wrapper.hs ├── Credit.hs ├── Swaps.hs └── ScheduledProduct.hs ├── examples ├── DemoContractAST.o ├── DemoContractAST.hi ├── Test.obsdb.xml ├── ForwardTrade1.obsdb.xml ├── ForwardTrade2.obsdb.xml ├── Option.obsdb.xml ├── FXBarrierOption.obsdb.xml ├── OilSwapTrade.obsdb.xml ├── Product1.timeseries.xml ├── VarianceSwap.timeseries.xml ├── DarkSpreadOption.timeseries.xml ├── OilSwapTrade.contract ├── Observables.obsdb.xml ├── WeatherContingent.obsdb.xml ├── ForwardTrade1.contract ├── CreditDefaultSwap.obsdb.xml ├── IndexAmortisingSwap.contract ├── SparkSpreadOption.timeseries.xml ├── DarkSpreadOption.obsdb.xml ├── Test.contract ├── VarianceSwap.contract ├── GasSwing.timeseries.xml ├── SparkSpreadOption.obsdb.xml ├── FXBarrierOption.contract ├── ForwardTrade1.timeseries.xml ├── ForwardTrade2.timeseries.xml ├── BasketOption.contract ├── Option.timeseries.xml ├── ChooserRangeAccrual.contract ├── CreditDefaultSwap.contract ├── OilSwapTrade.timeseries.xml ├── ForwardTrade2.contract ├── Product1.contract ├── WeatherContingent.timeseries.xml ├── IndexAmortisingSwap.timeseries.xml ├── Option.contract ├── Units.db.xml ├── JulienExample.hs ├── SparkSpreadOption.contract ├── DarkSpreadOption.contract ├── GasSwing.contract ├── Test.timeseries.xml ├── ChooserRangeAccrual.hs ├── DirtySparkSpreadOption.hs ├── DarkSpreadOptionTemplate.hs └── WeatherContingent.contract ├── generate-docs.hs ├── src ├── Display.hs ├── XmlUtils.hs ├── WriteDotGraph.hs ├── ObservableDB.hs ├── UnitsDB.hs └── DecisionTreeSimplify.hs ├── license.txt ├── regression-test.sh ├── dist └── package.conf.inplace ├── readme.markdown ├── netrium.cabal └── tool ├── Visualise.hs └── Normalise.hs /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /doc/minus.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/netrium/Netrium/HEAD/doc/minus.gif -------------------------------------------------------------------------------- /doc/plus.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/netrium/Netrium/HEAD/doc/plus.gif -------------------------------------------------------------------------------- /doc/synopsis.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/netrium/Netrium/HEAD/doc/synopsis.png -------------------------------------------------------------------------------- /share/Calendar.o: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/netrium/Netrium/HEAD/share/Calendar.o -------------------------------------------------------------------------------- /share/Common.hi: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/netrium/Netrium/HEAD/share/Common.hi -------------------------------------------------------------------------------- /share/Common.o: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/netrium/Netrium/HEAD/share/Common.o -------------------------------------------------------------------------------- /doc/hslogo-16.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/netrium/Netrium/HEAD/doc/hslogo-16.png -------------------------------------------------------------------------------- /share/Calendar.hi: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/netrium/Netrium/HEAD/share/Calendar.hi -------------------------------------------------------------------------------- /examples/DemoContractAST.o: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/netrium/Netrium/HEAD/examples/DemoContractAST.o -------------------------------------------------------------------------------- /examples/DemoContractAST.hi: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/netrium/Netrium/HEAD/examples/DemoContractAST.hi -------------------------------------------------------------------------------- /examples/Test.obsdb.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | -------------------------------------------------------------------------------- /examples/ForwardTrade1.obsdb.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | -------------------------------------------------------------------------------- /examples/ForwardTrade2.obsdb.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | -------------------------------------------------------------------------------- /examples/Option.obsdb.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | -------------------------------------------------------------------------------- /examples/FXBarrierOption.obsdb.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | -------------------------------------------------------------------------------- /examples/OilSwapTrade.obsdb.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | -------------------------------------------------------------------------------- /examples/Product1.timeseries.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | -------------------------------------------------------------------------------- /examples/VarianceSwap.timeseries.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | -------------------------------------------------------------------------------- /examples/DarkSpreadOption.timeseries.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | -------------------------------------------------------------------------------- /examples/OilSwapTrade.contract: -------------------------------------------------------------------------------- 1 | 2 | import Swaps 3 | 4 | contract = 5 | commoditySwap 6 | ((Market gasoil bbl us), (Market brentoil bbl uk)) 7 | (vol1, vol2) 8 | 5000 gbp cash 9 | [ date 2011 m 20 | m <- [1..12] ] 10 | 11 | -------------------------------------------------------------------------------- /examples/Observables.obsdb.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 5 | 6 | -------------------------------------------------------------------------------- /examples/WeatherContingent.obsdb.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | -------------------------------------------------------------------------------- /examples/ForwardTrade1.contract: -------------------------------------------------------------------------------- 1 | 2 | contract = 3 | forward 4 | (initialMarginFee <> exchangeFee 100) 5 | (Market gas thm nbp) 6 | vol1 7 | 0.45 gbp cash 8 | [ date 2011 1 d | d <- [2..3] ] 9 | [ date 2011 1 d | d <- [2..3] ] 10 | -------------------------------------------------------------------------------- /examples/CreditDefaultSwap.obsdb.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | -------------------------------------------------------------------------------- /share/Settlement.hs: -------------------------------------------------------------------------------- 1 | -- |Netrium is Copyright Anthony Waite, Dave Hewett, Shaun Laurens & Contributors 2009-2018, and files herein are licensed 2 | -- |under the MIT license, the text of which can be found in license.txt 3 | -- 4 | module Settlement where 5 | 6 | import Prelude hiding (and, or, min, max, abs, negate, not, read, until) 7 | import Contract 8 | import Common 9 | import Calendar 10 | 11 | -------------------------------------------------------------------------------- /examples/IndexAmortisingSwap.contract: -------------------------------------------------------------------------------- 1 | import Common 2 | import Observable 3 | import Swaps 4 | 5 | cSch = [mkdate 2011 m 31 | m <- [3,6,9,12] ] 6 | amortTable = [(300, 1.0), (500, 0.6), (600, 0.4), (800, 0.2), (1200, 0.1)] 7 | 8 | contract = indexAmortisingSwap 6000000 cSch (Currency "EUR", Currency "EUR") (CashFlowType "initialMargin", CashFlowType "initialMargin") amortTable (90/360) (primVar "USD.LIBOR.6M") (primVar "USD.LIBOR.SPOT") -------------------------------------------------------------------------------- /examples/SparkSpreadOption.timeseries.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | -------------------------------------------------------------------------------- /examples/DarkSpreadOption.obsdb.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | -------------------------------------------------------------------------------- /share/normalise-wrapper.hs: -------------------------------------------------------------------------------- 1 | -- |Netrium is Copyright Anthony Waite, Dave Hewett, Shaun Laurens & Contributors 2009-2018, and files herein are licensed 2 | -- |under the MIT license, the text of which can be found in license.txt 3 | -- 4 | module Main where 5 | 6 | import Prelude hiding (and, or, min, max, abs, negate, not, read, until) 7 | import Contract 8 | import Common 9 | 10 | import qualified Text.XML.HaXml.XmlContent as XML 11 | import qualified Text.XML.HaXml.Pretty as XML.PP 12 | import qualified Text.PrettyPrint as PP 13 | -------------------------------------------------------------------------------- /examples/Test.contract: -------------------------------------------------------------------------------- 1 | 2 | contract = ex3 3 | 4 | ex2 = anytime "%1" (between (date 2011 1 2) (date 2011 1 3) 5 | %|| between (date 2011 1 5) (date 2011 1 6)) (one quid) 6 | 7 | ex3 = anytime "%1" foo (one quid) 8 | ex4 = anytime "%1" (konst True) (one quid) 9 | 10 | ex5 = until (at (date 2011 1 2)) 11 | (anytime "%1" foo (one quid)) 12 | 13 | ex6 = or "%1" (one quid) 14 | (scale (konst 3) (one quid)) 15 | 16 | 17 | ex7 = cond foo (one quid) 18 | (scale (konst 2) (one quid)) 19 | 20 | quid = Financial gbp cash Nothing 21 | -------------------------------------------------------------------------------- /examples/VarianceSwap.contract: -------------------------------------------------------------------------------- 1 | import Calendar 2 | import Swaps 3 | 4 | -- Variance swap 5 | contract = varianceSwap strikePrice vegaAmount varianceAmount 6 | [date 2011 01 01, date 2011 01 06] 7 | (primVar "SPX Index") [10,11,10.5,13,15] 8 | (Currency "USD") (CashFlowType "cash") 9 | (daysLater 3) calendar 10 | where 11 | strikePrice = 16 12 | vegaAmount = 100000 13 | varianceAmount = vegaAmount / (strikePrice * 2) 14 | calendar = getBusinessDayCalendar "EEX Power" 15 | -------------------------------------------------------------------------------- /examples/GasSwing.timeseries.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | -------------------------------------------------------------------------------- /examples/SparkSpreadOption.obsdb.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | -------------------------------------------------------------------------------- /doc/mini_CalendarTest.html: -------------------------------------------------------------------------------- 1 | CalendarTest

CalendarTest

-------------------------------------------------------------------------------- /examples/FXBarrierOption.contract: -------------------------------------------------------------------------------- 1 | import Options 2 | 3 | -- Knockin down and in call option with european exercise. 4 | 5 | contract = option "selection[exercise-option]" exerciseDetails CallOption 100 (Currency "EUR") underlying 6 | where 7 | 8 | exerciseDetails = 9 | barrierDownAndIn cpardUSDEUR floorPrice $ 10 | europeanExercise (date 2011 06 01) strikePrice 11 | 12 | underlying strikePrice = 13 | allOf[ 14 | financial 10000 (Currency "USD") (CashFlowType "cash"), 15 | give $ financial 6500 (Currency "EUR") (CashFlowType "cash") 16 | ] 17 | 18 | strikePrice = 2.5 * quantity 19 | quantity = 10 20 | floorPrice = 0.7 21 | 22 | -------------------------------------------------------------------------------- /examples/ForwardTrade1.timeseries.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 9 | 10 | 3 11 | 12 | 15 | 16 | 17 | 18 | 19 | -------------------------------------------------------------------------------- /examples/ForwardTrade2.timeseries.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 9 | 10 | 3 11 | 12 | 15 | 16 | 17 | 18 | 19 | -------------------------------------------------------------------------------- /examples/BasketOption.contract: -------------------------------------------------------------------------------- 1 | import Options 2 | 3 | contract = 4 | option "opt" exerciseDetails CallOption emptyOptionAttrs underlying 5 | 6 | where 7 | -- A currency basket option in GBP on USD and EUR 8 | -- By exercising the option the holder gets 100 EUR and 100 USD 9 | -- for 200 GBP times the strike price 10 | 11 | underlying sp = (financial quantity usd cash) `and` (financial quantity eur cash) 12 | `and` give (financial (sp * 2 * quantity) gbp cash) 13 | quantity = 100 14 | 15 | -- simple european exercise 16 | 17 | exerciseDetails = europeanExercise (date 2013 06 01) strikePrice 18 | 19 | -- the strike price can be set at e.g. the weighted value of the basket currencies in gbp 20 | 21 | strikePrice = 0.78 -------------------------------------------------------------------------------- /examples/Option.timeseries.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 6 9 | 5 10 | 6 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | -------------------------------------------------------------------------------- /examples/ChooserRangeAccrual.contract: -------------------------------------------------------------------------------- 1 | import Common 2 | import Observable 3 | 4 | dailySch1 = [mkdate 2011 1 d | d <- [1..2]] 5 | dailySch2 = [mkdate 2011 2 d | d <- [1..2]] 6 | dailySch3 = [mkdate 2011 3 d | d <- [1..2]] 7 | 8 | --contract = chooserLeg 80 500 (last dailySch1) dailySch1 (Currency "EUR") (primVar "LIBOR.EUR.6M") (CashFlowType "initialMargin") 9 | contract = chooserNote [chooserLeg 80 500 (last dailySch1) dailySch1 (Currency "EUR") (primVar "LIBOR.EUR.6M") (CashFlowType "initialMargin"), 10 | chooserLeg 45 450 (last dailySch2) dailySch2 (Currency "EUR") (primVar "LIBOR.EUR.6M") (CashFlowType "initialMargin"), 11 | chooserLeg 50 550 (last dailySch3) dailySch3 (Currency "EUR") (primVar "LIBOR.EUR.6M") (CashFlowType "initialMargin")] -------------------------------------------------------------------------------- /doc/mini_Credit.html: -------------------------------------------------------------------------------- 1 | Credit

Credit

type CreditEvent

terminContract

-------------------------------------------------------------------------------- /examples/CreditDefaultSwap.contract: -------------------------------------------------------------------------------- 1 | import Calendar 2 | import Swaps 3 | 4 | -- First define the underlying asset, in this example a simple zcb 5 | underlying = zcb (date 2014 06 01) 100000000 (Currency "USD") (CashFlowType "cash") 6 | 7 | -- CDS 8 | -- Notional amount of $10M, 3 yearly payment at a given rate 9 | contract = creditDefaultSwap cEvents 1000000 [date 2012 01 01, date 2013 01 01, date 2014 01 01] (Currency "USD") cpardfRate (CashFlowType "cash") (90/360) underlying 10 | -- 2 credit events in this example: 11 | -- - Bankruptcy, which would cause a physical settlement and a termination of the contract 12 | -- - Failure to pay, which would cause a cash settlement of $1M but not terminate the contract 13 | where cEvents = [("Bankruptcy", True, 'P', 50000000, (Currency "USD"), cparbEvent1), 14 | ("Failure to Pay", False, 'C', 1000000, (Currency "USD"), cparbEvent2) ] -------------------------------------------------------------------------------- /examples/OilSwapTrade.timeseries.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 9 | 10 | 3 11 | 12 | 15 | 16 | 17 | 18 | 4 19 | 20 | 21 | 22 | 23 | 24 | -------------------------------------------------------------------------------- /examples/ForwardTrade2.contract: -------------------------------------------------------------------------------- 1 | 2 | contract = 3 | forward' 4 | (initialMarginFee <> exchangeFee 100) 5 | (Market gas thm nbp) 6 | vol1 7 | 0.45 gbp cash 8 | -- delivering gas every 30 minutes, with a 30 min duration. 9 | [ datetime 2011 1 day hour min 10 | | day <- [1..31] 11 | , hour <- [0..23] 12 | , min <- [0, 30] ] 13 | (duration 0 30 0) 14 | 15 | 16 | forward' :: FeeCalc 17 | -> Market 18 | -> Volume 19 | -> Price -> Currency -> CashFlowType 20 | -> Schedule -> Duration 21 | -> Contract 22 | forward' fee market vol pr cur cft sch dur = 23 | give (calcFee fee vol pr cur sch) 24 | `and` 25 | allOf 26 | [ when (at t) $ physicalWith vol market (withDuration dur) 27 | `and` give (financial (vol * pr) cur cft) 28 | | t <- sch ] 29 | 30 | 31 | 32 | -------------------------------------------------------------------------------- /doc/frames.html: -------------------------------------------------------------------------------- 1 | 4 | 5 | 6 | 7 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | -------------------------------------------------------------------------------- /doc/CalendarTest.html: -------------------------------------------------------------------------------- 1 | CalendarTest

 

CalendarTest

-------------------------------------------------------------------------------- /generate-docs.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/runghc 2 | 3 | -- On Unix/MacOSX run as: 4 | -- ./generate-docs.hs 5 | -- 6 | -- On Windows: 7 | -- runghc generate-docs.hs 8 | -- 9 | -- Then point your browser at ./doc/index.html 10 | 11 | import System.Process 12 | import System.Directory 13 | import System.FilePath 14 | import System.Exit 15 | import Control.Monad 16 | import Data.Char 17 | 18 | outDir = "doc" 19 | shareDir = "share" 20 | srcDir = "src" 21 | 22 | main = do 23 | libmodules <- getLibModules 24 | exitcode <- rawSystem "haddock" (haddockArgs libmodules) 25 | when (exitcode /= ExitSuccess) $ 26 | putStrLn "Generating 'haddock' documentation failed" 27 | exitWith exitcode 28 | 29 | getLibModules :: IO [FilePath] 30 | getLibModules = do 31 | files <- getDirectoryContents shareDir 32 | return [ shareDir file 33 | | file <- files 34 | , takeExtension file == ".hs", isUpper (head file) ] 35 | 36 | haddockArgs libmodules = 37 | [ "--html" 38 | , "-o", outDir 39 | , "--optghc=-i" ++ srcDir ] 40 | ++ libmodules 41 | -------------------------------------------------------------------------------- /doc/mini_Swaps.html: -------------------------------------------------------------------------------- 1 | Swaps

Swaps

commoditySwap

varianceSwap

indexAmortisingSwap

creditDefaultSwap

-------------------------------------------------------------------------------- /examples/Product1.contract: -------------------------------------------------------------------------------- 1 | import ScheduledProduct 2 | import Calendar 3 | 4 | contract = 5 | scheduledProductRelative (date 2011 08 01) vol productUkPowerDayAheadPeak 6 | where 7 | -- the volume is specified at the point when the product is acquired 8 | vol = 30 9 | 10 | 11 | productUkPowerDayAheadPeak :: ScheduledProductRelative Volume 12 | productUkPowerDayAheadPeak = 13 | defineScheduledProductRelative 14 | (\vol -> physical vol (Market electricity mwh uk)) 15 | (relativeDeliverySchedule 16 | (daysLater 1) -- first day 17 | (daysLater 1) -- last day (same for single day product) 18 | cal 19 | deliveryShape) 20 | 21 | where 22 | -- should the volume be part of the product or should it be specified at 23 | -- the point when the product is acquired? 24 | vol = 30 25 | 26 | cal = getBusinessDayCalendar "EEX Power" 27 | 28 | -- half hour delivery between 7am -- 7pm (last delivery at 6:30pm) 29 | deliveryShape = 30 | complexDeliveryShape [ deliverAtTimeOfDay hr ms | hr <- [7..18], ms <- [0,30] ] 31 | -------------------------------------------------------------------------------- /src/Display.hs: -------------------------------------------------------------------------------- 1 | -- |Netrium is Copyright Anthony Waite, Dave Hewett, Shaun Laurens & Contributors 2009-2018, and files herein are licensed 2 | -- |under the MIT license, the text of which can be found in license.txt 3 | -- 4 | {-# OPTIONS_HADDOCK hide #-} 5 | module Display ( 6 | 7 | module Data.Tree, 8 | Display(..), 9 | trimDepth, 10 | module WriteDotGraph, 11 | 12 | disp, disp', 13 | 14 | ) where 15 | 16 | import Control.Monad (void) 17 | import Data.Tree 18 | import System.Process 19 | 20 | import WriteDotGraph 21 | 22 | 23 | class Display a where 24 | toTree :: a -> Tree String 25 | 26 | trimDepth :: Int -> Tree String -> Tree String 27 | trimDepth 0 (Node _ _) = Node "..." [] 28 | trimDepth n (Node l ts) = Node l (map (trimDepth (n-1)) ts) 29 | 30 | -- Utils for use in ghci: 31 | 32 | disp :: Display a => a -> IO () 33 | disp = disp' 8 34 | 35 | disp' :: Display a => Int -> a -> IO () 36 | disp' depth x = do 37 | writeDotFile "out.dot" (trimDepth depth $ toTree x) 38 | void $ rawSystem "dot" ["-Tsvg", "-o", "out.svg", "out.dot"] 39 | void $ rawSystem "eog" ["out.svg"] 40 | -------------------------------------------------------------------------------- /examples/WeatherContingent.timeseries.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 9 | 10 | 85 11 | 86 12 | 89 13 | 14 | 15 | 16 | 17 | 4 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | -------------------------------------------------------------------------------- /examples/IndexAmortisingSwap.timeseries.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 9 | 10 | 3 11 | 12 | 15 | 16 | 17 | 18 | 4 19 | 20 | 23 | 24 | 25 | 26 | 27 | 28 | -------------------------------------------------------------------------------- /doc/index-frames.html: -------------------------------------------------------------------------------- 1 |

Modules

-------------------------------------------------------------------------------- /license.txt: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2009-2015 Anthony Waite, Dave Hewett, Shaun Laurens and other contributors 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in 13 | all copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 21 | THE SOFTWARE. -------------------------------------------------------------------------------- /share/Credit.hs: -------------------------------------------------------------------------------- 1 | -- |Netrium is Copyright Anthony Waite, Dave Hewett, Shaun Laurens & Contributors 2009-2018, and files herein are licensed 2 | -- |under the MIT license, the text of which can be found in license.txt 3 | -- 4 | -- Module for credit 5 | module Credit where 6 | 7 | import Prelude hiding (and, or, min, max, abs, negate, not, read, until) 8 | import Contract 9 | import Common 10 | import Calendar 11 | 12 | import Data.Time 13 | import Data.Monoid 14 | 15 | -- |Type for credit events 16 | type CreditEvent = (String, -- Name of the event 17 | Bool, -- True if contract if terminated as a result of the event 18 | Char, -- Settlement type (C for cash, P for physical) 19 | Price, -- Capital payment as a result of the event 20 | Currency, -- Currency of the capital payment 21 | Obs Bool) -- True if the event has happened 22 | 23 | -- |Function that returns True if any of the given credit events have happened and are terminal 24 | terminContract :: [CreditEvent] 25 | -> Obs Bool 26 | terminContract [] = konst False 27 | terminContract ((_, cTermin, _, _, _, cHasHappened):xs) = 28 | ifthen (cHasHappened %&& konst cTermin) 29 | (konst True) 30 | (terminContract xs) 31 | -------------------------------------------------------------------------------- /regression-test.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | CONTRACTS="$@" 4 | 5 | if test "${CONTRACTS}" = "" 6 | then 7 | echo "Usage: ./regression-test [contract...]" 8 | echo "One or more .contract files, for example:" 9 | echo "$ ./regression-test examples/*.contract" 10 | exit 11 | fi 12 | 13 | for CONTRACT in ${CONTRACTS}; do 14 | echo -n "${CONTRACT}: " 15 | 16 | CONTRACT_DIR="$(dirname ${CONTRACT})" 17 | CONTRACT_BASE=${CONTRACT%%.contract} 18 | 19 | if test -f ${CONTRACT_BASE}.obsdb.xml 20 | then 21 | OBSDB="--obs-db=${CONTRACT_BASE}.obsdb.xml" 22 | else 23 | OBSDB=; 24 | fi 25 | if test -f "${CONTRACT_DIR}/Units.db.xml" 26 | then 27 | UNITSDB="--units-db=${CONTRACT_DIR}/Units.db.xml" 28 | else 29 | UNITSDB= 30 | fi 31 | 32 | if normalise ${UNITSDB} ${OBSDB} ${CONTRACT} ${CONTRACT}.xml --fast \ 33 | > normalise-out.log 2>&1 34 | then 35 | echo -n "compiled OK" 36 | if simulate ${CONTRACT}.xml ${CONTRACT_BASE}.timeseries.xml ${CONTRACT_BASE}.out \ 37 | > simulate-out.log 2>&1 38 | then 39 | echo ", simulate OK" 40 | cat normalise-out.log 41 | cat simulate-out.log 42 | else 43 | echo ", simulate FAILED:" 44 | cat simulate-out.log 45 | fi 46 | else 47 | echo "compile FAILED:" 48 | cat normalise-out.log 49 | fi 50 | done 51 | rm -f normalise-out.log simulate-out.log 52 | -------------------------------------------------------------------------------- /examples/Option.contract: -------------------------------------------------------------------------------- 1 | import Options 2 | 3 | contract = 4 | option "opt" exerciseDetails CallOption emptyOptionAttrs underlying 5 | 6 | where 7 | -- note that the underlying contract describes *both* what we recieve and 8 | -- how much we pay for it (which depends on the strike price). 9 | -- of course for a vanilla european option the strike price is fixed, 10 | -- but with something like an asian option, it's calculated, 11 | -- which is why here the strike price is a paramater to underlying rather 12 | -- than us just using the 'strikePrice' variable defined below. 13 | 14 | underlying sp = physical quantity (Market gas thm nbp) 15 | `and` give (financial (sp * quantity) gbp cash) 16 | quantity = 10 17 | 18 | -- Note also, that this 'sp' (strike price) paramater can be used as the 19 | -- basis for multiple cash flows, e.g. regular payments, rather than just 20 | -- a payment at the time the option is exercised. 21 | 22 | 23 | -- here we have a barrier condition on a different index to the price of 24 | -- the underlying, the barrier is based on the temperature where as the 25 | -- the underlying is for gas. 26 | 27 | exerciseDetails = 28 | barrierDownAndIn temperatureUK floorTemp $ 29 | europeanExercise (date 2011 06 01) strikePrice 30 | 31 | strikePrice = 2.5 32 | floorTemp = 5 --degrees 33 | -------------------------------------------------------------------------------- /examples/Units.db.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | -------------------------------------------------------------------------------- /doc/index.html: -------------------------------------------------------------------------------- 1 |

 

Modules

-------------------------------------------------------------------------------- /dist/package.conf.inplace: -------------------------------------------------------------------------------- 1 | [InstalledPackageInfo {installedPackageId = InstalledPackageId "netrium-demo-0.4.7-inplace", sourcePackageId = PackageIdentifier {pkgName = PackageName "netrium-demo", pkgVersion = Version {versionBranch = [0,4,7], versionTags = []}}, license = AllRightsReserved, copyright = "2011 Netrium Ltd", maintainer = "Well-Typed LLP", author = "Well-Typed LLP", stability = "", homepage = "", pkgUrl = "", description = "", category = "", exposed = True, exposedModules = ["WriteDotGraph","Display","Observable","ObservableDB","UnitsDB","Observations","Contract","DecisionTree","DecisionTreeSimplify","Interpreter","XmlUtils"], hiddenModules = [], importDirs = ["/Users/julien/Dropbox/netrium-demo/dist/build"], libraryDirs = ["/Users/julien/Dropbox/netrium-demo/dist/build"], hsLibraries = ["HSnetrium-demo-0.4.7"], extraLibraries = [], extraGHCiLibraries = [], includeDirs = [], includes = [], depends = [InstalledPackageId "HaXml-1.20.2-29214cce3bce799fb6916d8bda608f71",InstalledPackageId "base-4.3.1.0-167743fc0dd86f7f2a24843a933b9dce",InstalledPackageId "containers-0.4.0.0-18deac99a132f04751d862b77aab136e",InstalledPackageId "process-1.0.1.5-107ac5b78a5845608025ca13d328fdc5",InstalledPackageId "time-1.2.0.3-57ebba2cc05370f666b7eceba5e468a9"], hugsOptions = [], ccOptions = [], ldOptions = [], frameworkDirs = [], frameworks = [], haddockInterfaces = ["/Users/julien/Dropbox/netrium-demo/dist/doc/html/netrium-demo/netrium-demo.haddock"], haddockHTMLs = ["/Users/julien/Dropbox/netrium-demo/dist/doc/html/netrium-demo"]} 2 | ] -------------------------------------------------------------------------------- /readme.markdown: -------------------------------------------------------------------------------- 1 | ### About 2 | 3 | Netrium enables financial engineers to precisely describe and execute both simple and exotic contracts with both financial and physical delivery. 4 | 5 | The Netrium project offers a Haskell based domain specific language and dedicated compiler to support the definition and operational exe­cu­tion of fin­an­cial and phys­ical energy con­tracts, with arbit­rary option­al­ity and con­di­tion­al­ity. This helps trad­ing desks con­trol the oper­a­tional risk asso­ci­ated with non-standard trans­ac­tions. The imple­ment­a­tion is based on the aca­demic paper [Adven­tures in Fin­an­cial Engin­eer­ing](http://research.microsoft.com/en-us/um/people/simonpj/papers/financial-contracts/contracts-icfp.htm) by Simon Peyton Jones and Jean-Marc Eber, with a range of extensions to allow for path-dependent contracts and support for physical commodities. 6 | 7 | ### License 8 | 9 | The Netrium codebase is licensed under the permissive MIT license. 10 | 11 | We ask that any ports to other languages retain reference to netrium.org. 12 | 13 | ### Contacts 14 | 15 | * For further information about the software, please contact: opensource@netrium.org 16 | 17 | ### Documentation 18 | 19 | The following documentation will be useful to understand the Netrium Language and tools: 20 | 21 | * [Language Introduction](https://github.com/netrium/Netrium/wiki/Language) 22 | * [Command Line Tools](https://github.com/netrium/Netrium/wiki/Command-Line-Tools) 23 | 24 | ### Copyright 25 | 26 | Netrium is Copyright 2009-2018 Netrium.org Contributors. 27 | -------------------------------------------------------------------------------- /examples/JulienExample.hs: -------------------------------------------------------------------------------- 1 | -- |Netrium is Copyright Anthony Waite, Dave Hewett, Shaun Laurens & Contributors 2009-2018, and files herein are licensed 2 | -- |under the MIT license, the text of which can be found in license.txt 3 | import Contract 4 | import Common 5 | import Options 6 | import Data.List (transpose) 7 | 8 | commoditySpreadOption :: ChoiceId 9 | -> [( Market 10 | , Volume 11 | , Price, Currency, CashFlowType 12 | , SegmentedSchedule 13 | , FeeCalc )] 14 | -> DiffDateTime 15 | -> OptionDirection 16 | -> StrikePrice 17 | -> Contract 18 | commoditySpreadOption cid legs optionDiffTime opDir strikePrice = 19 | allOf 20 | [ legOption groupedLeg $ \strikePrice -> 21 | -- do something here with strikePrice, else it's never used! 22 | allOf [ forward fee m pr cur cft vol seg 23 | | (m, pr, cur, cft, vol, seg, fee) <- groupedLeg ] 24 | | groupedLeg <- groupedLegs ] 25 | 26 | where 27 | groupedLegs = 28 | transpose 29 | [ [ (m, pr, cur, cft, vol, seg, fee) | seg <- sch ] 30 | | (m, pr, cur, cft, vol, sch, fee) <- legs ] 31 | 32 | legOption groupedLeg = 33 | option cid (europeanExercise (optionTime groupedLeg) strikePrice) opDir 34 | 35 | optionTime groupedLeg = 36 | adjustDateTime earliestDeliveryTime optionDiffTime 37 | where 38 | earliestDeliveryTime = 39 | minimum [ t | (_, _, _, _, _, (t:_), _) <- groupedLeg ] 40 | -------------------------------------------------------------------------------- /examples/SparkSpreadOption.contract: -------------------------------------------------------------------------------- 1 | import Options 2 | 3 | -- Daily exercise at 9:00 on the day preceding the supply day 4 | -- (this is supposed to be on every EEX business day but for now it does every calendar day - to be updated when we have a proper calendar) 5 | contract = commoditySpreadOption "choice" 6 | legs 7 | exerciseDate 8 | paymentDate 9 | CallOption 10 | strikePrice gbp (CashFlowType "initialMargin") 11 | premium gbp 12 | where 13 | strikePrice = 2 * powerVol 14 | exerciseDate = daysEarlier 1 <> atTimeOfDay 9 00 15 | paymentDate = exerciseDate 16 | premium = 0 17 | 18 | legs = [gasLeg, carbonLeg, electricityLeg] 19 | 20 | -- TTF gas: daily delivery at 6:00 CET 21 | -- All months have 31 days - to be updated when we have a proper calendar 22 | gasLeg = 23 | ( Market (Commodity "Gas") (Unit "MWh") (Location "TTF"), gasVol 24 | , gasPrice, (Currency "GBP"), (CashFlowType "initialMargin") 25 | , [ [datetime 2011 m d 6 0 ] | m <- [1..12], d <- [1..31] ] 26 | , exchangeFee 50 27 | ) 28 | 29 | -- Carbon: yearly certificates split into daily deliveries at 12:00 30 | carbonLeg = 31 | ( Market (Commodity "Carbon") (Unit "t") (Location "EU"), carbonVol 32 | , carbonPrice, (Currency "GBP"), (CashFlowType "initialMargin") 33 | , [ [datetime 2011 m d 12 0 ] | m <- [1..12], d <- [1..31] ] 34 | , exchangeFee 75) 35 | 36 | -- CE Power: delivery every 15 minutes 37 | electricityLeg = 38 | ( Market (Commodity "Electricity") (Unit "MWh") (Location "Amprion HVG"), powerVol 39 | , powerPrice, (Currency "EUR"), (CashFlowType "initialMargin") 40 | , [ [datetime 2011 m d h i | h <- [0..23], i <- [0,15,30,45] ] | m <- [1], d <- [1..31] ] 41 | , exchangeFee 100 ) 42 | -------------------------------------------------------------------------------- /examples/DarkSpreadOption.contract: -------------------------------------------------------------------------------- 1 | import Options 2 | import Calendar 3 | 4 | -- Daily exercise at 15:00 on the day preceding the supply day 5 | -- (this is supposed to be on every fourth EEX business day but for now it does every fourth calendar day - to be updated when we have a proper calendar) 6 | contract = commoditySpreadOption "choice" legs 7 | (calendarDaysEarlier calendar 4 <> atTimeOfDay 15 00) 8 | (calendarDaysLater calendar 5) 9 | CallOption 10 | strikePrice gbp (CashFlowType "initialMargin") 11 | premium gbp 12 | where strikePrice = 7 * powerVol 13 | premium = 3 14 | calendar = getBusinessDayCalendar "EEX Power" 15 | 16 | legs = [coalLeg, carbonLeg, electricityLeg] 17 | months = [1..1] -- Should be [1..12], but cut down to reduce runtime 18 | 19 | -- API2 coal: monthly delivery (assumption is 1st of the month) 20 | coalLeg = 21 | ( Market (Commodity "Coal") (Unit "MWh") (Location "ARA"), coalVol 22 | , coalPrice, (Currency "USD"), (CashFlowType "initialMargin") 23 | , [ [datetime 2011 m 1 0 0 ] | m <- months ] 24 | , exchangeFee 50 25 | ) 26 | 27 | -- Carbon: yearly certificates split into monthly deliveries at 12:00 28 | carbonLeg = 29 | ( Market (Commodity "Carbon") (Unit "t") (Location "EU"), carbonVol 30 | , carbonPrice, (Currency "GBP"), (CashFlowType "initialMargin") 31 | , [ [datetime 2011 m 1 12 0 ] | m <- months ] 32 | , exchangeFee 75) 33 | 34 | -- CE Power: delivery every 15 minutes 35 | electricityLeg = 36 | ( Market (Commodity "Electricity") (Unit "MWh") (Location "Amprion HVG"), powerVol 37 | , powerPrice, (Currency "EUR"), (CashFlowType "initialMargin") 38 | , [ [datetime 2011 m d h i | d <- [1..31], h <- [0..23], i <- [0,15,30,45] ] | m <- months ] 39 | , exchangeFee 100 ) 40 | -------------------------------------------------------------------------------- /doc/doc-index.html: -------------------------------------------------------------------------------- 1 | (Index)

 

-------------------------------------------------------------------------------- /src/XmlUtils.hs: -------------------------------------------------------------------------------- 1 | -- |Netrium is Copyright Anthony Waite, Dave Hewett, Shaun Laurens & Contributors 2009-2018, and files herein are licensed 2 | -- |under the MIT license, the text of which can be found in license.txt 3 | -- 4 | {-# OPTIONS_HADDOCK hide #-} 5 | {-# OPTIONS_GHC -fno-warn-orphans #-} 6 | module XmlUtils where 7 | 8 | import Text.XML.HaXml.Namespaces (localName) 9 | import Text.XML.HaXml.Types (QName(..)) 10 | import Text.XML.HaXml.XmlContent 11 | import Data.Time 12 | 13 | attrStr :: Monad m => QName -> Element t -> m String 14 | attrStr n (Elem _ as _) = 15 | case lookup n as of 16 | Nothing -> fail ("expected attribute " ++ localName n) 17 | Just av -> return (attr2str av) 18 | 19 | attrRead :: (Read b, Monad m) => QName -> Element t -> m b 20 | attrRead n e = do 21 | str <- attrStr n e 22 | case reads str of 23 | [(v,_)] -> return v 24 | _ -> fail $ "cannot parse attribute " ++ localName n ++ ": " ++ str 25 | 26 | mkElemAC :: QName -> [Attribute] -> [Content ()] -> Content () 27 | mkElemAC x as cs = CElem (Elem x as cs) () 28 | 29 | readText :: Read a => XMLParser a 30 | readText = do 31 | t <- text 32 | case reads t of 33 | [(v,_)] -> return v 34 | _ -> fail $ "cannot parse " ++ t 35 | 36 | 37 | instance XmlContent Bool where 38 | parseContents = do 39 | e@(Elem t _ _) <- element ["True", "False"] 40 | commit $ interior e $ case localName t of 41 | "True" -> return True 42 | "False" -> return False 43 | x -> fail $ "cannot parse " ++ x 44 | 45 | toContents True = [mkElemC "True" []] 46 | toContents False = [mkElemC "False" []] 47 | 48 | instance XmlContent Double where 49 | parseContents = inElement "Double" readText 50 | toContents t = [mkElemC "Double" (toText (show t))] 51 | 52 | instance HTypeable UTCTime where 53 | toHType _ = Defined "Time" [] [] 54 | 55 | instance XmlContent UTCTime where 56 | parseContents = inElement "Time" readText 57 | toContents t = [mkElemC "Time" (toText (show t))] 58 | -------------------------------------------------------------------------------- /examples/GasSwing.contract: -------------------------------------------------------------------------------- 1 | 2 | contract = 3 | gasSwing 4 | (initialMarginFee <> exchangeFee 100) 5 | (Market gas thm nbp) 6 | (900, 1000, 1100) 7 | 0.45 gbp cash 8 | 1 9 | [ (datetime 2011 1 (d-1) 16 00, date 2011 1 d) | d <- [2..3] ] 10 | 11 | 12 | ----------------------------------------------------------------------- 13 | 14 | --TODO: change this to use the ordinary Schedule type, 15 | -- and calculate the option time differently: 16 | type Schedule' = [(Time, Time)] -- option time, delivery time 17 | 18 | gasSwing :: FeeCalc 19 | -> Market 20 | -> (Volume, Volume, Volume) -- ^ (low, normal, high) delivery volumes 21 | -> Price -> Currency -> CashFlowType 22 | -> Int -- ^ number of exercise times 23 | -> Schedule' 24 | -> Contract 25 | gasSwing fee market (lowVol,normalVol, highVol) pr cur cft exerciseCount sch = 26 | allOf [ give (calcFee fee normalVol pr cur (map snd sch)) 27 | , letin "count" (konst (fromIntegral exerciseCount)) $ \count0 -> 28 | foldr leg (\_ -> zero) sch count0 29 | ] 30 | 31 | where 32 | leg (optTime, delTime) remainder count = 33 | when (at optTime) $ 34 | cond (count %<= 0) 35 | normal 36 | (or "normal" normal 37 | (or "low-high" low high)) 38 | where 39 | normal = when (at delTime) $ 40 | allOf [ delivery normalVol 41 | , remainder count 42 | ] 43 | low = when (at delTime) $ 44 | allOf [ delivery lowVol 45 | , letin "count" (count - 1) (\count' -> remainder count') 46 | ] 47 | high = when (at delTime) $ 48 | allOf [ delivery highVol 49 | , letin "count" (count - 1) (\count' -> remainder count') 50 | ] 51 | 52 | delivery vol = and (physical vol market) 53 | (give (financial (vol * pr) cur cft)) 54 | 55 | -------------------------------------------------------------------------------- /doc/doc-index-H.html: -------------------------------------------------------------------------------- 1 | (Index - H)

 

Index - H

horizonPrPricing
-------------------------------------------------------------------------------- /doc/doc-index-60.html: -------------------------------------------------------------------------------- 1 | (Index - <)

 

Index - <

<>Common
-------------------------------------------------------------------------------- /doc/mini_Calendar.html: -------------------------------------------------------------------------------- 1 | Calendar

Calendar

Calendar types 5 |

type DayType

type CalendarPeriod

type Calendar

type CalendarOffsetTime

Helper functions 6 |

numTypeDays

dayInRange

calDaysOffset

getSubCalendarByDayType

getSubCalendarByDate

businessDaysOffset

calendarDaysOffset

Calendar instances 7 |

getCalendar

-------------------------------------------------------------------------------- /doc/doc-index-Y.html: -------------------------------------------------------------------------------- 1 | (Index - Y)

 

Index - Y

yearsEarlierCommon
yearsLaterCommon
-------------------------------------------------------------------------------- /doc/doc-index-K.html: -------------------------------------------------------------------------------- 1 | (Index - K)

 

Index - K

konstObservable, Contract
konstSlicesPricing
-------------------------------------------------------------------------------- /src/WriteDotGraph.hs: -------------------------------------------------------------------------------- 1 | -- |Netrium is Copyright Anthony Waite, Dave Hewett, Shaun Laurens & Contributors 2009-2018, and files herein are licensed 2 | -- |under the MIT license, the text of which can be found in license.txt 3 | -- 4 | {-# OPTIONS_HADDOCK hide #-} 5 | module WriteDotGraph (renderDotGraph, writeDotFile) where 6 | 7 | import Data.Tree 8 | 9 | labelTree :: Tree a -> Int -> (Tree (Int,a), Int) 10 | labelTree (Node l ts) n = (Node (n,l) ts', n') 11 | where 12 | (ts', n') = labelForest ts [] (n+1) 13 | 14 | labelForest :: [Tree a] -> [Tree (Int, a)] -> Int -> ([Tree (Int, a)], Int) 15 | labelForest [] nts n = (reverse nts, n) 16 | labelForest (t:ts) nts n = let (nt, n') = labelTree t n 17 | in labelForest ts (nt:nts) n' 18 | 19 | treeToGraph :: Tree (Int, String) -> ([(Int, String)], [(Int, Int)]) 20 | treeToGraph (Node (n, label) ts) = 21 | let node = (n, label) 22 | edges = [ (n, n') | Node (n', _) _ <- ts ] 23 | (nodes', edges') = unzip (map treeToGraph ts) 24 | in (node:concat nodes', edges++concat edges') 25 | 26 | writeDotFile :: FilePath -> Tree String -> IO () 27 | writeDotFile file tree = writeFile file (renderDotGraph tree) 28 | 29 | renderDotGraph :: Tree String -> String 30 | renderDotGraph tree = 31 | unlines ( 32 | [header 33 | ,graphDefaultAtribs 34 | ,nodeDefaultAtribs 35 | ,edgeDefaultAtribs] 36 | ++ map makeNode nodes 37 | ++ map makeEdge edges 38 | ++ [footer] 39 | ) 40 | where 41 | (nodes, edges) = treeToGraph (fst $ labelTree tree 0) 42 | 43 | makeNode (n,l) = "\t" ++ show n ++ " [label=\"" ++ escape l ++ "\"];" 44 | 45 | makeEdge (n, n') = "\t" ++ show n ++ " -> " ++ show n' ++ "[];" 46 | 47 | escape [] = [] 48 | escape ('\n':cs) = "\\n" ++ escape cs 49 | escape ('"' :cs) = "\\\"" ++ escape cs 50 | escape (c :cs) = c : escape cs 51 | 52 | 53 | header, footer :: String 54 | header = "digraph contract {" 55 | footer = "}" 56 | 57 | graphDefaultAtribs, nodeDefaultAtribs, edgeDefaultAtribs :: String 58 | graphDefaultAtribs = "\tgraph [fontsize=14, fontcolor=black, color=black];" 59 | nodeDefaultAtribs = "\tnode [label=\"\\N\", width=\"0.75\", shape=ellipse];" 60 | edgeDefaultAtribs = "\tedge [fontsize=10];" 61 | -------------------------------------------------------------------------------- /doc/doc-index-Q.html: -------------------------------------------------------------------------------- 1 | (Index - Q)

 

Index - Q

quartersEarlierCommon
quartersLaterCommon
-------------------------------------------------------------------------------- /doc/doc-index-W.html: -------------------------------------------------------------------------------- 1 | (Index - W)

 

Index - W

WhenContract
whenContract
writeTreeAsDotPricing
-------------------------------------------------------------------------------- /doc/Credit.html: -------------------------------------------------------------------------------- 1 | Credit

 

Credit

Description

Copyright 2011 Netrium Ltd. All rights reserved. 5 |

Module for credit 6 |

Synopsis

Documentation

type CreditEvent = (String, Bool, Char, Price, Currency, Obs Bool)

Type for credit events 7 |

terminContract :: [CreditEvent] -> Obs Bool

Function that returns True if any of the given credit events have happened and are terminal 8 |

-------------------------------------------------------------------------------- /examples/Test.timeseries.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 13 | 14 | 16 | 17 | 18 | 19 | 22 | 23 | 24 | 25 | 26 | 28 | 29 | 30 | 31 | 32 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 43 | 44 | 45 | 46 | 47 | 48 | %1 49 | foo 50 | 51 | 52 | gbpcash 53 | 54 | 55 | 1.0 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | -------------------------------------------------------------------------------- /doc/doc-index-Z.html: -------------------------------------------------------------------------------- 1 | (Index - Z)

 

Index - Z

zcbCommon
ZeroContract
zeroContract
zeroFeeCommon
zipWithAllPricing
-------------------------------------------------------------------------------- /src/ObservableDB.hs: -------------------------------------------------------------------------------- 1 | -- |Netrium is Copyright Anthony Waite, Dave Hewett, Shaun Laurens & Contributors 2009-2018, and files herein are licensed 2 | -- |under the MIT license, the text of which can be found in license.txt 3 | -- 4 | module ObservableDB where 5 | 6 | import Control.Monad (liftM, liftM2) 7 | import Text.XML.HaXml.Namespaces (localName) 8 | import Text.XML.HaXml.Types (QName(..)) 9 | import Text.XML.HaXml.XmlContent 10 | 11 | import XmlUtils 12 | 13 | newtype ObservableDB = ObservableDB { unObservableDB :: [ObservableDecl] } 14 | deriving (Show, Read) 15 | data ObservableDecl = ObservableDecl String ObservableType 16 | deriving (Show, Read) 17 | data ObservableType = Double | Bool 18 | deriving (Show, Read) 19 | 20 | instance HTypeable ObservableDB where 21 | toHType _ = Defined "ObservableDB" [] [] 22 | 23 | instance XmlContent ObservableDB where 24 | parseContents = inElement "ObservableDB" $ 25 | liftM ObservableDB parseContents 26 | 27 | toContents (ObservableDB ds) = 28 | [mkElemC "ObservableDB" (toContents ds)] 29 | 30 | instance HTypeable ObservableDecl where 31 | toHType _ = Defined "ObservableDecl" [] [] 32 | 33 | instance XmlContent ObservableDecl where 34 | parseContents = do 35 | e@(Elem t _ _) <- element ["ObservableDecl"] 36 | commit $ interior e $ case localName t of 37 | "ObservableDecl" -> liftM2 ObservableDecl (attrStr (N "name") e) parseContents 38 | x -> fail $ "cannot parse " ++ x 39 | 40 | toContents (ObservableDecl n t) = 41 | [mkElemAC (N "ObservableDecl") [(N "name", str2attr n)] (toContents t)] 42 | 43 | instance HTypeable ObservableType where 44 | toHType _ = Defined "ObservableType" [] [] 45 | 46 | instance XmlContent ObservableType where 47 | parseContents = do 48 | e@(Elem t _ _) <- element ["Double", "Bool"] 49 | commit $ interior e $ case localName t of 50 | "Double" -> return Double 51 | "Bool" -> return Bool 52 | x -> fail $ "cannot parse " ++ x 53 | 54 | toContents Double = [mkElemC "Double" []] 55 | toContents Bool = [mkElemC "Bool" []] 56 | 57 | compileObservableDB :: ObservableDB -> String 58 | compileObservableDB = unlines . map compileObservable . unObservableDB 59 | where 60 | compileObservable (ObservableDecl n t) = 61 | n ++ " :: Obs " ++ ct ++ "\n" ++ 62 | n ++ " = " ++ ce ++ " " ++ show n 63 | where 64 | ct = case t of 65 | Double -> "Double" 66 | Bool -> "Bool" 67 | ce = case t of 68 | Double -> "primVar" 69 | Bool -> "primCond" 70 | -------------------------------------------------------------------------------- /examples/ChooserRangeAccrual.hs: -------------------------------------------------------------------------------- 1 | -- |Netrium is Copyright Anthony Waite, Dave Hewett, Shaun Laurens & Contributors 2009-2018, and files herein are licensed 2 | -- |under the MIT license, the text of which can be found in license.txt 3 | module ChooserRangeAccrual where 4 | 5 | import Prelude hiding (and, or, until, read, all, any, max, min, negate, abs) 6 | import Common 7 | import Contract 8 | import DecisionTree 9 | import Interpreter 10 | import Data.Time 11 | import List hiding (and) 12 | 13 | import Display 14 | 15 | type Price = Double 16 | 17 | financial = financial' . konst 18 | financial' o cur = Scale o (One (Financial cur)) 19 | 20 | m = (*1000000) 21 | 22 | dailySch1 = [date 2011 1 d | d <- [1..2]] 23 | dailySch2 = [date 2011 2 d | d <- [1..2]] 24 | dailySch3 = [date 2011 3 d | d <- [1..2]] 25 | 26 | chooserLeg :: Int -- range for observation period 27 | -> Int -- index strike for observation period 28 | -> Time -- coupon settlement date 29 | -> Schedule -- dates for observation period 30 | -> Contract 31 | 32 | chooserLeg range strike setD sch = 33 | 34 | foldr daily settlementDate sch (konst 0) 35 | 36 | where 37 | daily (day) next daysWithinRange = 38 | when (at day) $ 39 | read "daysWithinRange" 40 | (daysWithinRange %+ indexInRange strike range) 41 | (next (var "daysWithinRange")) 42 | 43 | settlementDate couponAmount = when (at setD) $ financial' paymentDue (Currency "eur") 44 | where 45 | -- bit of a cheat here. should be a count of actual business days, not total number of days 46 | paymentDue = primVar "LIBOR.EUR.6M" %* var "daysWithinRange" %/ konst (fromIntegral(length sch)) 47 | 48 | -- If the 6M Euro libor rate is within strike +/- range then increase days within range 49 | -- otherwise dont increase days within range 50 | indexInRange strike range = 51 | 52 | ifthen (primVar "LIBOR.EUR.6M" %<= konst (fromIntegral(strike + range)) 53 | %&& primVar "LIBOR.EUR.6M" %> konst (fromIntegral(strike - range))) 54 | (konst 1) (konst 0) 55 | 56 | 57 | ex1 = chooserLeg 80 500 (last dailySch1) dailySch1 58 | 59 | chooserNote :: [Int] 60 | -> [Int] 61 | -> [Schedule] 62 | -> Contract 63 | chooserNote rangeList strikeList schedules = 64 | allOf 65 | [ chooserLeg range strike (last sch) sch 66 | | (range, strike, sch) <- zip3 rangeList strikeList schedules ] 67 | 68 | 69 | 70 | ex3 :: Contract 71 | ex3 = chooserNote 72 | [80,45,50] 73 | [500,450, 550] 74 | [dailySch1,dailySch2,dailySch3] 75 | -------------------------------------------------------------------------------- /doc/doc-index-G.html: -------------------------------------------------------------------------------- 1 | (Index - G)

 

Index - G

getAmRateCommon
getCalendarCalendar
getSubCalendarByDateCalendar
getSubCalendarByDayTypeCalendar
GiveContract
giveContract
-------------------------------------------------------------------------------- /doc/doc-index-V.html: -------------------------------------------------------------------------------- 1 | (Index - V)

 

Index - V

Var 
1 (Data Constructor)Observable
2 (Type/Class)Contract
varObservable, Contract
varianceSwapSwaps
VarNameObservable
VolumeCommon
-------------------------------------------------------------------------------- /doc/doc-index-R.html: -------------------------------------------------------------------------------- 1 | (Index - R)

 

Index - R

rateModelPricing
rateModelsPricing
ratesPricing
ReadContract
readContract
ResultObservable
runDotPricing
RVPricing
rvsToDotPricing
-------------------------------------------------------------------------------- /doc/doc-index-O.html: -------------------------------------------------------------------------------- 1 | (Index - O)

 

Index - O

ObsObservable, Contract
onDayOfMonthCommon
OneContract
oneContract
optionOptions
OptionDirectionOptions
OrContract
orContract
orZeroCommon
-------------------------------------------------------------------------------- /doc/doc-index-L.html: -------------------------------------------------------------------------------- 1 | (Index - L)

 

Index - L

lastnCommon
latticeImagePricing
lift2PrPricing
lift2PrAllPricing
lift3PrPricing
liftPrPricing
Location 
1 (Type/Class)Contract
2 (Data Constructor)Contract
-------------------------------------------------------------------------------- /doc/doc-index-I.html: -------------------------------------------------------------------------------- 1 | (Index - I)

 

Index - I

IfThenObservable
ifthenObservable, Contract
IndexCommon
indexAmortisingSwapSwaps
initialMarginFeeCommon
inMonthCommon
isFalseObservable
isTrueObservable
-------------------------------------------------------------------------------- /doc/doc-index-U.html: -------------------------------------------------------------------------------- 1 | (Index - U)

 

Index - U

UnderlyingCommon
UnderlyingContractOptions
UnderlyingPriceOptions
Unit 
1 (Type/Class)Contract
2 (Data Constructor)Contract
UnOpObservable
unPrPricing
UntilContract
untilContract
-------------------------------------------------------------------------------- /doc/mini_Options.html: -------------------------------------------------------------------------------- 1 | Options

Options

Types 5 |

type ExerciseCondition

type ConditionWindow

type ExpirationCondition

type UnderlyingPrice

type UnderlyingContract

type StrikePrice

data OptionDirection

data ExerciseDetails

Option template 6 |

option

Templates for option parameters 7 |

Exercise time 8 |

europeanExercise

americanExercise

bermudanExercise

Payoff 9 |

asianExercise

Exercise conditions 10 |

barrierKnockIn

barrierUpAndIn

barrierDownAndIn

More advanced option templates 11 |

commoditySpreadOption

-------------------------------------------------------------------------------- /src/UnitsDB.hs: -------------------------------------------------------------------------------- 1 | -- |Netrium is Copyright Anthony Waite, Dave Hewett, Shaun Laurens & Contributors 2009-2018, and files herein are licensed 2 | -- |under the MIT license, the text of which can be found in license.txt 3 | -- 4 | module UnitsDB where 5 | 6 | import Control.Monad (liftM) 7 | import Text.XML.HaXml.Namespaces (localName) 8 | import Text.XML.HaXml.Types (QName(..)) 9 | import Text.XML.HaXml.XmlContent 10 | 11 | import XmlUtils 12 | 13 | newtype UnitsDB = UnitsDB { unUnitsDB :: [UnitDecl] } 14 | deriving (Show, Read) 15 | 16 | data UnitDecl = CommodityDecl String 17 | | UnitDecl String 18 | | LocationDecl String 19 | | CurrencyDecl String 20 | | CashFlowTypeDecl String 21 | deriving (Show, Read) 22 | 23 | 24 | instance HTypeable UnitsDB where 25 | toHType _ = Defined "UnitsDB" [] [] 26 | 27 | instance XmlContent UnitsDB where 28 | parseContents = inElement "UnitsDB" (liftM UnitsDB parseContents) 29 | toContents (UnitsDB ds) = [mkElemC "UnitsDB" (toContents ds)] 30 | 31 | 32 | instance HTypeable UnitDecl where 33 | toHType _ = Defined "UnitDecl" [] [] 34 | 35 | instance XmlContent UnitDecl where 36 | parseContents = do 37 | e@(Elem t _ _) <- element ["CommodityDecl", "CashFlowTypeDecl", 38 | "UnitDecl", 39 | "LocationDecl", "CurrencyDecl"] 40 | commit $ interior e $ case localName t of 41 | "CashFlowTypeDecl" -> liftM CashFlowTypeDecl (attrStr (N "name") e) 42 | "CommodityDecl" -> liftM CommodityDecl (attrStr (N "name") e) 43 | "UnitDecl" -> liftM UnitDecl (attrStr (N "name") e) 44 | "LocationDecl" -> liftM LocationDecl (attrStr (N "name") e) 45 | "CurrencyDecl" -> liftM CurrencyDecl (attrStr (N "name") e) 46 | x -> fail $ "cannot parse " ++ x 47 | 48 | toContents (CommodityDecl n) = 49 | [mkElemAC (N "CommodityDecl") [(N "name", str2attr n)] []] 50 | toContents (CashFlowTypeDecl n) = 51 | [mkElemAC (N "CashFlowTypeDecl") [(N "name", str2attr n)] []] 52 | toContents (UnitDecl n) = 53 | [mkElemAC (N "UnitDecl") [(N "name", str2attr n)] []] 54 | toContents (LocationDecl n) = 55 | [mkElemAC (N "LocationDecl") [(N "name", str2attr n)] []] 56 | toContents (CurrencyDecl n) = 57 | [mkElemAC (N "CurrencyDecl") [(N "name", str2attr n)] []] 58 | 59 | 60 | compileUnitsDB :: UnitsDB -> String 61 | compileUnitsDB = unlines . map compileUnit . unUnitsDB 62 | where 63 | compileUnit (CashFlowTypeDecl n) = 64 | n ++ " :: CashFlowType\n" ++ 65 | n ++ " = CashFlowType " ++ show n 66 | compileUnit (CommodityDecl n) = 67 | n ++ " :: Commodity\n" ++ 68 | n ++ " = Commodity " ++ show n 69 | compileUnit (UnitDecl n) = 70 | n ++ " :: Unit\n" ++ 71 | n ++ " = Unit " ++ show n 72 | compileUnit (LocationDecl n) = 73 | n ++ " :: Location\n" ++ 74 | n ++ " = Location " ++ show n 75 | compileUnit (CurrencyDecl n) = 76 | n ++ " :: Currency\n" ++ 77 | n ++ " = Currency " ++ show n 78 | -------------------------------------------------------------------------------- /doc/doc-index-F.html: -------------------------------------------------------------------------------- 1 | (Index - F)

 

Index - F

FeeCalc 
1 (Type/Class)Common
2 (Data Constructor)Common
FinancialContract
financialCommon
fixedFeeCommon
fixedPriceCommon
FixingScheduleCommon
floatingPriceCommon
formatDotStmtPricing
forwardCommon
-------------------------------------------------------------------------------- /netrium.cabal: -------------------------------------------------------------------------------- 1 | name: netrium 2 | version: 0.6.0 3 | synopsis: Contract normaliser and simulator 4 | description: Netrium enables financial engineers to precisely describe and execute both simple and exotic contracts with both financial and physical delivery. 5 | category: Finance 6 | author: Well-Typed LLP 7 | maintainer: Well-Typed LLP 8 | copyright: 2009-2018 Anthony Waite, Dave Hewett, Shaun Laurens and other contributors 9 | license: MIT 10 | license-file: license.txt 11 | 12 | build-type: Simple 13 | cabal-version: >= 1.8 14 | 15 | data-dir: share 16 | data-files: normalise-wrapper.hs 17 | Common.hs 18 | Options.hs 19 | Calendar.hs 20 | Swaps.hs 21 | Credit.hs 22 | Settlement.hs 23 | ScheduledProduct.hs 24 | extra-source-files: examples/Units.db.xml 25 | examples/*.hs 26 | examples/*.contract 27 | examples/*.obsdb.xml 28 | examples/*.timeseries.xml 29 | regression-test.sh 30 | generate-docs.hs 31 | 32 | library 33 | hs-source-dirs: src 34 | exposed-modules: WriteDotGraph 35 | Display 36 | Observable 37 | ObservableDB 38 | UnitsDB 39 | Observations 40 | Contract 41 | DecisionTree 42 | DecisionTreeSimplify 43 | Interpreter 44 | XmlUtils 45 | Valuation 46 | build-depends: base >= 3.0 && < 5, 47 | containers >= 0.3 && < 1, 48 | process >= 1.0 && < 2, 49 | time >= 1.1 && < 2, 50 | HaXml == 1.25.* 51 | 52 | executable normalise 53 | hs-source-dirs: tool 54 | main-is: Normalise.hs 55 | build-depends: netrium, 56 | base >= 3.0 && < 5, 57 | process >= 1.0 && < 2, 58 | filepath >= 1.1 && < 2, 59 | directory >= 1.0 && < 2, 60 | HaXml == 1.25.* 61 | 62 | executable simulate 63 | hs-source-dirs: tool 64 | main-is: Simulate.hs 65 | build-depends: netrium, 66 | base >= 3.0 && < 5, 67 | containers >= 0.3 && < 1, 68 | HaXml == 1.25.*, 69 | pretty == 1.1.3.*, 70 | directory >= 1.0 && < 2, 71 | filepath 72 | 73 | executable visualise 74 | hs-source-dirs: tool 75 | main-is: Visualise.hs 76 | build-depends: netrium, 77 | base >= 3.0 && < 5, 78 | directory >= 1.0 && < 2, 79 | filepath, 80 | process >= 1.0 && < 2, 81 | HaXml == 1.25.* 82 | 83 | source-repository head 84 | type: git 85 | location: https://github.com/netrium/Netrium 86 | -------------------------------------------------------------------------------- /doc/doc-index-T.html: -------------------------------------------------------------------------------- 1 | (Index - T)

 

Index - T

takePrPricing
terminContractCredit
TimeObservable, Contract
timeHorizonObservable
toGregorian'Common
TradeableContract
TradedDateCommon
Trader 
1 (Type/Class)Common
2 (Data Constructor)Common
treeToDotPricing
-------------------------------------------------------------------------------- /doc/doc-index-N.html: -------------------------------------------------------------------------------- 1 | (Index - N)

 

Index - N

NamedCondObservable
NamedValObservable
NeedNamedCondObservable
NeedNamedValObservable
negateObservable, Contract
nextFalseObservable
nextTrueObservable
nodeLabelPricing
notObservable
numberListPricing
numTypeDaysCalendar
-------------------------------------------------------------------------------- /doc/doc-index-B.html: -------------------------------------------------------------------------------- 1 | (Index - B)

 

Index - B

barrierDownAndInOptions
barrierKnockInOptions
barrierUpAndInOptions
BeforeObservable
beforeObservable, Contract
bermudanExerciseOptions
betweenObservable, Contract
bigKPricing
BinOpObservable
Book 
1 (Type/Class)Common
2 (Data Constructor)Common
businessDaysOffsetCalendar
-------------------------------------------------------------------------------- /doc/doc-index-M.html: -------------------------------------------------------------------------------- 1 | (Index - M)

 

Index - M

MarginingScheduleCommon
Market 
1 (Type/Class)Common
2 (Data Constructor)Common
MarketNettingAgreement 
1 (Type/Class)Common
2 (Data Constructor)Common
maxObservable, Contract
minObservable, Contract
mkdateObservable
Model 
1 (Type/Class)Pricing
2 (Data Constructor)Pricing
modelStartPricing
monthsEarlierCommon
monthsLaterCommon
-------------------------------------------------------------------------------- /doc/doc-index-37.html: -------------------------------------------------------------------------------- 1 | (Index - %)

 

Index - %

%&&Observable, Contract
%*Observable, Contract
%+Observable, Contract
%-Observable, Contract
%/Observable, Contract
%<Observable, Contract
%<=Observable, Contract
%==Observable, Contract
%>Observable, Contract
%>=Observable, Contract
%||Observable, Contract
-------------------------------------------------------------------------------- /doc/doc-index-E.html: -------------------------------------------------------------------------------- 1 | (Index - E)

 

Index - E

earliestTimeHorizonObservable
europeanExerciseOptions
evalObservable
evalCPricing
evalOPricing
evermoreFalseObservable
evermoreTrueObservable
exchPricing
exchangeFeeCommon
ExerciseConditionOptions
ExerciseDetails 
1 (Type/Class)Options
2 (Data Constructor)Options
expectedValuePricing
expectedValuePrPricing
ExpirationConditionOptions
-------------------------------------------------------------------------------- /examples/DirtySparkSpreadOption.hs: -------------------------------------------------------------------------------- 1 | -- |Netrium is Copyright Anthony Waite, Dave Hewett, Shaun Laurens & Contributors 2009-2018, and files herein are licensed 2 | -- |under the MIT license, the text of which can be found in license.txt 3 | module Main where 4 | 5 | import Prelude hiding (and, or, min, max, abs, negate, not, read, until) 6 | 7 | import DemoContractAST 8 | import Contract (Obs, primVar) 9 | import Common (atTimeOfDay, date, datetime, exchangeFee, (<>)) 10 | -- import Options (OptionDirection(CallOption)) 11 | import Calendar 12 | 13 | import qualified Text.XML.HaXml.XmlContent as XML 14 | import qualified Text.XML.HaXml.Pretty as XML.PP 15 | import qualified Text.PrettyPrint as PP 16 | 17 | ------------------------------------------------------------------------------- 18 | -- Contract template function itself 19 | -- 20 | 21 | -- Daily exercise at 15:00 on the day preceding the supply day 22 | -- (this is supposed to be on every fourth EEX business day but for now it does every fourth calendar day - to be updated when we have a proper calendar) 23 | 24 | contract 25 | = namedContract "Commodity Spread Option" $ commoditySpreadOption legs 26 | (calendarDaysEarlier calendar 4 <> atTimeOfDay 07 00) 27 | (calendarDaysEarlier calendar 4 <> atTimeOfDay 15 00) 28 | CallOption 29 | strike 30 | (CashFlowType "initialMargin") 31 | premium 32 | where calendar = getBusinessDayCalendar "EEX Power" 33 | strike = (strikePrice, Currency "GBP") 34 | strikePrice = powerPrice * powerVol 35 | premium = (2, Currency "GBP") 36 | 37 | coalVol :: Double 38 | coalVol = 5000 39 | coalPrice :: Double 40 | coalPrice = 12 41 | carbonVol :: Double 42 | carbonVol = 100 43 | carbonPrice :: Double 44 | carbonPrice = 70 45 | powerVol :: Double 46 | powerVol = 50 47 | powerPrice :: Double 48 | powerPrice = 16 49 | 50 | legs = [coalLeg, carbonLeg, electricityLeg] 51 | 52 | -- API2 coal: monthly delivery (assumption is 1st of the month) 53 | coalLeg = 54 | ( Market (Commodity "Coal") (Unit "MWh") (Location "ARA"), coalVol 55 | , coalPrice, (Currency "USD"), (CashFlowType "initialMargin") 56 | , [ schedule ] 57 | , exchangeFee 50 58 | ) 59 | where 60 | schedule = deliverySchedule (date 2011 1 1) (date 2011 12 31) 61 | calendar deliverAtMidnight 62 | calendar = newCalendar "carbonCalendar" [(date 2011 m 1, BusinessDay) | m <- [1..12]] 63 | 64 | -- Carbon: yearly certificates split into monthly deliveries at 12:00 65 | carbonLeg = 66 | ( Market (Commodity "Carbon") (Unit "t") (Location "EU"), carbonVol 67 | , carbonPrice, (Currency "EUR"), (CashFlowType "initialMargin") 68 | , [ schedule ] 69 | , exchangeFee 75) 70 | where 71 | schedule = deliverySchedule (date 2011 1 1) (date 2011 12 31) 72 | calendar deliverAtMidnight 73 | calendar = newCalendar "carbonCalendar" [(date 2011 m 1, BusinessDay) | m <- [1..12]] 74 | 75 | -- CE Power: delivery every 15 minutes 76 | electricityLeg = 77 | ( Market (Commodity "Electricity") (Unit "MWh") (Location "Amprion HVG"), powerVol 78 | , powerPrice, (Currency "GBP"), (CashFlowType "initialMargin") 79 | , [ schedule ] 80 | , exchangeFee 100 ) 81 | where 82 | calendar = getBusinessDayCalendar "EEX Power" 83 | schedule = deliverySchedule (date 2011 1 1) (date 2011 12 31) 84 | calendar shape 85 | shape = complexDeliveryShape [deliverAtTimeOfDay h m | h <- [0..23], m <- [0,15,30,45]] 86 | 87 | 88 | ------------------------------------------------------------------------------- 89 | -- Template program main 90 | -- 91 | 92 | main = do 93 | putStr (renderXml contract) 94 | where 95 | -- renderXml = show 96 | renderXml = PP.renderStyle PP.style { PP.mode = PP.OneLineMode } 97 | . XML.PP.document 98 | . toXml False 99 | -------------------------------------------------------------------------------- /doc/doc-index-S.html: -------------------------------------------------------------------------------- 1 | (Index - S)

 

Index - S

ScaleContract
scaleContract
ScaleFactorContract
ScheduleCommon
scheduledContractCommon
seasonsCommon
SegmentedScheduleCommon
SettlementAgreement 
1 (Type/Class)Common
2 (Data Constructor)Common
SettlementScheduleCommon
SettlementVolumeVarianceCommon
showNodesPricing
simpleModelPricing
simplifyWithinHorizonObservable
snellPricing
squareCommon
StepsObservable
StrikePriceOptions
substObservable
-------------------------------------------------------------------------------- /examples/DarkSpreadOptionTemplate.hs: -------------------------------------------------------------------------------- 1 | -- |Netrium is Copyright Anthony Waite, Dave Hewett, Shaun Laurens & Contributors 2009-2018, and files herein are licensed 2 | -- |under the MIT license, the text of which can be found in license.txt 3 | module Main where 4 | 5 | import Prelude hiding (and, or, min, max, abs, negate, not, read, until) 6 | 7 | import Contract 8 | import Common 9 | import Options 10 | import Calendar 11 | 12 | import qualified Text.XML.HaXml.XmlContent as XML 13 | import qualified Text.XML.HaXml.Pretty as XML.PP 14 | import qualified Text.PrettyPrint as PP 15 | 16 | 17 | ------------------------------------------------------------------------------- 18 | -- Template program main 19 | -- 20 | 21 | main = do 22 | 23 | -- read the contract template parameters from the program stdin 24 | -- one paramater per line, in Haskell 'Read' syntax 25 | -- For this example the following input file would do: 26 | -- 27 | -- 7 28 | -- 3 29 | 30 | -- the contract xml is written on program stdout 31 | -- invoke as so: 32 | -- ./DarkSpreadOptionTemplate < templateInputs.txt > contract.xml 33 | 34 | powerPrice <- readLn 35 | premium <- readLn 36 | 37 | let contract = contractTemplate (konst powerPrice) (konst premium) 38 | 39 | putStr (renderXml contract) 40 | 41 | renderXml = PP.renderStyle PP.style { PP.mode = PP.OneLineMode } 42 | . XML.PP.document 43 | . XML.toXml False 44 | 45 | ------------------------------------------------------------------------------- 46 | -- Contrac template function itself 47 | -- 48 | 49 | -- Daily exercise at 15:00 on the day preceding the supply day 50 | -- (this is supposed to be on every fourth EEX business day but for now it does every fourth calendar day - to be updated when we have a proper calendar) 51 | 52 | contractTemplate powerPrice premium 53 | = commoditySpreadOption "choice" legs 54 | (workingDaysEarlier calendar 4 <> atTimeOfDay 15 00) 55 | (workingDaysLater calendar 5) 56 | CallOption 57 | strikePrice (Currency "GBP") (CashFlowType "initialMargin") 58 | premium (Currency "GBP") 59 | where strikePrice = powerPrice * powerVol 60 | calendar = getCalendar "EEX Power" 61 | 62 | legs = [coalLeg, carbonLeg, electricityLeg] 63 | 64 | -- API2 coal: monthly delivery (assumption is 1st of the month) 65 | coalLeg = 66 | ( Market (Commodity "Coal") (Unit "MWh") (Location "ARA"), coalVol 67 | , coalPrice, (Currency "USD"), (CashFlowType "initialMargin") 68 | , [ [datetime 2011 m 1 0 0 ] | m <- [1..12] ] 69 | , exchangeFee 50 70 | ) 71 | 72 | -- Carbon: yearly certificates split into monthly deliveries at 12:00 73 | carbonLeg = 74 | ( Market (Commodity "Carbon") (Unit "t") (Location "EU"), carbonVol 75 | , carbonPrice, (Currency "GBP"), (CashFlowType "initialMargin") 76 | , [ [datetime 2011 m 1 12 0 ] | m <- [1..12] ] 77 | , exchangeFee 75) 78 | 79 | -- CE Power: delivery every 15 minutes 80 | electricityLeg = 81 | ( Market (Commodity "Electricity") (Unit "MWh") (Location "Amprion HVG"), powerVol 82 | , powerPrice, (Currency "EUR"), (CashFlowType "initialMargin") 83 | , [ [datetime 2011 m d h i | d <- [1..31], h <- [0..23], i <- [0,15,30,45] ] | m <- [1] ] 84 | , exchangeFee 100 ) 85 | 86 | 87 | ------------------------------------------------------------------------------- 88 | -- Generated 89 | -- 90 | 91 | -- This part would be generated automatically by a variation of the normalise 92 | -- program. For ordinary (non-template) contracts the normalise program 93 | -- generate these automatically. We will eventually want something similar for 94 | -- templates. 95 | 96 | coalVol :: Obs Double 97 | coalVol = primVar "coalVol" 98 | coalPrice :: Obs Double 99 | coalPrice = primVar "coalPrice" 100 | carbonVol :: Obs Double 101 | carbonVol = primVar "carbonVol" 102 | carbonPrice :: Obs Double 103 | carbonPrice = primVar "carbonPrice" 104 | powerVol :: Obs Double 105 | powerVol = primVar "powerVol" 106 | powerPrice :: Obs Double 107 | powerPrice = primVar "powerPrice" 108 | -------------------------------------------------------------------------------- /doc/doc-index-A.html: -------------------------------------------------------------------------------- 1 | (Index - A)

 

Index - A

absObservable, Contract
absorbPricing
adjustDateCommon
adjustDateTimeCommon
adjustTimeCommon
AfterObservable
afterObservable, Contract
allOfCommon
americanExerciseOptions
AmortisationTableCommon
AndContract
andContract
andFeeCommon
andPrPricing
AnytimeContract
anytimeContract
asianExerciseOptions
assignIdsPricing
AtObservable
atObservable, Contract
atTimeOfDayCommon
-------------------------------------------------------------------------------- /doc/doc-index-D.html: -------------------------------------------------------------------------------- 1 | (Index - D)

 

Index - D

dateCommon
DateTimeCommon
datetimeCommon
DayCountConventionCommon
dayInRangeCalendar
daysEarlierCommon
daysLaterCommon
DayTypeCalendar
DGiveCommon
DiffDateTime 
1 (Type/Class)Common
2 (Data Constructor)Common
DirectionCommon
discPricing
dotExtPricing
dotGraphPricing
dotGraphHdrPricing
dotJoinPricing
DTakeCommon
Duration 
1 (Type/Class)Contract
2 (Data Constructor)Contract
durationCommon
-------------------------------------------------------------------------------- /doc/doc-index-P.html: -------------------------------------------------------------------------------- 1 | (Index - P)

 

Index - P

parseObsCondObservable
parseObsRealObservable
PhysicalContract
physicalCommon
physicalWithDurationCommon
PiObservable
PR 
1 (Type/Class)Pricing
2 (Data Constructor)Pricing
prevSlicePricing
PriceCommon
PriceCurveCommon
primCondObservable, Contract
primVarObservable, Contract
printObsObservable
printTreePricing
probabilityLatticePricing
Product 
1 (Type/Class)Common
2 (Data Constructor)Common
prToDotPricing
PutOptionOptions
-------------------------------------------------------------------------------- /doc/mini_Contract.html: -------------------------------------------------------------------------------- 1 | Contract

Contract

Contract type definition 5 |

data Tradeable

data Duration

data Commodity

data Unit

data Location

data Currency

data CashFlowType

type ScaleFactor

type ChoiceId

data Contract

type Var

type Time

data Obs a

konst

var

primVar

primCond

at

before

after

between

ifthen

negate

max

min

abs

(%==)

(%>)

(%>=)

(%<)

(%<=)

(%&&)

(%||)

(%+)

(%-)

(%*)

(%/)

-------------------------------------------------------------------------------- /doc/mini_Pricing.html: -------------------------------------------------------------------------------- 1 | Pricing

Pricing

Value Processes 5 |

The basics 6 |

data PR a

type RV a

Value process helpers 7 |

takePr

horizonPr

andPr

Value process lifting 8 |

liftPr

lift2Pr

lift2PrAll

lift3Pr

zipWithAll

Models 9 |

data Model

simpleModel

Process primitives 10 |

bigK

condPr

disc

absorb

snell

Lattices 11 |

Simple calculation 12 |

prevSlice

rates

Probability calculation 13 |

probabilityLattice

Expected value 14 |

expectedValue

expectedValuePr

Valuation semantics 15 |

Valuation semantics for contracts 16 |

evalC

Valuation semantics for observables 17 |

evalO

Functions for Graphviz output 18 |

latticeImage

printTree

writeTreeAsDot

runDot

prToDot

rvsToDot

assignIds

numberList

showNodes

nodeLabel

treeToDot

dotJoin

dotGraph

dotGraphHdr

formatDotStmt

-------------------------------------------------------------------------------- /doc/mini_Observable.html: -------------------------------------------------------------------------------- 1 | Observable

Observable

type Time

mkdate

data Obs a

konst

type VarName

var

primVar

primCond

at

before

after

between

(%==)

(%>)

(%>=)

(%<)

(%<=)

(%&&)

(%||)

(%+)

(%-)

(%*)

(%/)

ifthen

negate

not

max

min

abs

parseObsCond

parseObsReal

printObs

eval

data Steps a

subst

isTrue

isFalse

nextTrue

nextFalse

evermoreTrue

evermoreFalse

timeHorizon

earliestTimeHorizon

simplifyWithinHorizon

-------------------------------------------------------------------------------- /src/DecisionTreeSimplify.hs: -------------------------------------------------------------------------------- 1 | -- |Netrium is Copyright Anthony Waite, Dave Hewett, Shaun Laurens & Contributors 2009-2018, and files herein are licensed 2 | -- |under the MIT license, the text of which can be found in license.txt 3 | -- 4 | {-# LANGUAGE DeriveFunctor, GADTs, PatternGuards #-} 5 | 6 | module DecisionTreeSimplify ( 7 | decisionTreeSimple, 8 | decisionStepWithTime, 9 | simplifyWait 10 | ) where 11 | 12 | import Contract 13 | import Observable (Steps(..)) 14 | import qualified Observable as Obs 15 | import DecisionTree 16 | 17 | import Prelude hiding (product, until, and, id) 18 | import Data.List hiding (and) 19 | 20 | 21 | -- --------------------------------------------------------------------------- 22 | -- * Apply our knowledge of time 23 | -- --------------------------------------------------------------------------- 24 | 25 | decisionTreeSimple :: Time -> Contract -> DecisionTree 26 | decisionTreeSimple t c = unfoldDecisionTree 27 | decisionStepWithTime 28 | (initialProcessState t c) 29 | 30 | decisionStepWithTime :: ProcessState -> (DecisionStep ProcessState, Time) 31 | decisionStepWithTime st@(PSt time _ _) = case decisionStep st of 32 | Done -> (Done, time) 33 | 34 | Trade d sf t st1 -> (Trade d sf t st1, time) 35 | 36 | Choose p id st1 st2 -> (Choose p id st1 st2, time) 37 | 38 | ObserveCond o st1 st2 -> case Obs.eval time o of 39 | Result True -> decisionStepWithTime st1 40 | Result False -> decisionStepWithTime st2 41 | _ -> (ObserveCond o st1 st2, time) 42 | 43 | ObserveValue o k -> case Obs.eval time o of 44 | Result v -> decisionStepWithTime (k v) 45 | _ -> (ObserveValue o k, time) 46 | 47 | Wait conds opts -> case simplifyWait time conds (not (null opts)) of 48 | Left st' -> decisionStepWithTime st' 49 | Right [] -> (Done, time) 50 | Right conds' -> (Wait conds' opts, time) 51 | 52 | -- The Wait action is the complicated one 53 | -- 54 | simplifyWait :: Time 55 | -> [(Obs Bool, Time -> ProcessState)] 56 | -> Bool 57 | -> Either ProcessState 58 | [(Obs Bool, Time -> ProcessState)] 59 | simplifyWait time conds opts = 60 | 61 | -- Check if any conditions are currently true, 62 | case checkCondTrue time conds of 63 | 64 | -- if so we can run one rather than waiting. 65 | Left k -> Left (k time) 66 | 67 | -- If all the conditions are evermore false... 68 | Right [] | opts -> Right [(konst False, \time' -> PSt time' [] [])] 69 | | otherwise -> Right [] 70 | 71 | -- Otherwise, all conditions are either false or are unknown. 72 | Right otherConds -> 73 | 74 | -- We look at the remaining conditions and check if there is 75 | -- a time at which one of the conditions will become true. 76 | case Obs.earliestTimeHorizon time otherConds of 77 | 78 | -- Of course, there may be no such time, in which case we 79 | -- simply return a new Wait using the remaining conditions 80 | Nothing -> Right otherConds 81 | 82 | -- but if this time does exists (call it the time horizon) 83 | -- then we can use it to simplify or eliminate the 84 | -- remaining conditions. 85 | -- Note that we also get the continuation step associated 86 | -- with the condition that becomes true at the horizon. 87 | Just (horizon, k) -> 88 | 89 | -- For each remaining condition we try to simplify it 90 | -- based on the knowledge that the time falls in the 91 | -- range between now and the time horizon (exclusive). 92 | -- If a condition will be false for the whole of this 93 | -- time range then it can be eliminated. 94 | let simplifiedConds = [ (obs', k') 95 | | (obs, k') <- otherConds 96 | , let obs' = Obs.simplifyWithinHorizon 97 | time horizon obs 98 | , not (Obs.isFalse time obs') ] 99 | 100 | -- It is possible that all the conditions are false 101 | -- in the time period from now up to (but not 102 | -- including) the horizon. 103 | in if null simplifiedConds 104 | 105 | -- In that case the condition associated with the 106 | -- time horizon will become true first, and we 107 | -- can advance time to the horizon and follow its 108 | -- associated continuation. 109 | then if opts then Right [(at horizon, k)] 110 | else Left (k horizon) 111 | 112 | -- Otherwise, we return a new Wait, using the 113 | -- simplified conditions 114 | else Right ((at horizon, k) : simplifiedConds) 115 | 116 | checkCondTrue :: Time -> [(Obs Bool, a)] -> Either a [(Obs Bool, a)] 117 | checkCondTrue time conds 118 | | ((_,k) :_) <- trueConds = Left k 119 | | otherwise = Right otherConds' 120 | where 121 | (trueConds, otherConds) = partition (Obs.isTrue time . fst) conds 122 | otherConds' = filter (not . Obs.evermoreFalse time . fst) otherConds 123 | -------------------------------------------------------------------------------- /tool/Visualise.hs: -------------------------------------------------------------------------------- 1 | -- |Netrium is Copyright Anthony Waite, Dave Hewett, Shaun Laurens & Contributors 2009-2018, and files herein are licensed 2 | -- |under the MIT license, the text of which can be found in license.txt 3 | -- 4 | {-# LANGUAGE PatternGuards #-} 5 | 6 | module Main where 7 | 8 | import Contract 9 | import DecisionTreeSimplify 10 | import Display 11 | import Paths_netrium 12 | 13 | import Data.Maybe 14 | import Data.Version 15 | import System.Environment 16 | import System.Exit 17 | import System.Console.GetOpt 18 | import System.IO 19 | import System.Directory 20 | import System.Process 21 | import System.FilePath 22 | 23 | import Text.XML.HaXml.XmlContent 24 | 25 | 26 | data OutputMode = OutputSvg | OutputPng | OutputDot 27 | 28 | outputExtension OutputSvg = "svg" 29 | outputExtension OutputPng = "png" 30 | outputExtension OutputDot = "dot" 31 | 32 | data Options = 33 | Options 34 | { optMode :: OutputMode 35 | , optDecisionTree :: Bool 36 | , optStartTime :: Maybe Time 37 | , optDepth :: Maybe Int 38 | , optVersion :: Bool 39 | } 40 | 41 | defaultOptions :: Options 42 | defaultOptions = 43 | Options 44 | { optMode = OutputSvg 45 | , optDecisionTree = False 46 | , optStartTime = Nothing 47 | , optDepth = Nothing 48 | , optVersion = False 49 | } 50 | 51 | optDepthDefault :: Int 52 | optDepthDefault = 8 53 | 54 | options :: [OptDescr (Options -> Options)] 55 | options = 56 | [ Option [] ["syntax-tree"] 57 | (NoArg (\ opts -> opts { optDecisionTree = False })) 58 | "Generate the contract syntax tree (default mode)" 59 | , Option [] ["decision-tree"] 60 | (NoArg (\ opts -> opts { optDecisionTree = True })) 61 | "Generate the contract decision tree" 62 | , Option [] ["start-time"] 63 | (ReqArg (\ arg opts -> opts { 64 | optStartTime = Just (readArg "start-time" arg) 65 | }) "TIME") 66 | "Contract start time (required in decision tree mode)" 67 | , Option [] ["tree-depth"] 68 | (ReqArg (\ arg opts -> opts { 69 | optDepth = Just (readArg "tree-depth" arg) 70 | }) "NUM") 71 | ("Limit the tree depth (decision tree mode default is " 72 | ++ show optDepthDefault ++ ")") 73 | , Option [] ["svg"] 74 | (NoArg (\ opts -> opts { optMode = OutputSvg })) 75 | "Output in SVG image format (default format)" 76 | , Option [] ["png"] 77 | (NoArg (\ opts -> opts { optMode = OutputPng })) 78 | "Output in PNG image format" 79 | , Option [] ["dot"] 80 | (NoArg (\ opts -> opts { optMode = OutputDot })) 81 | "Output in DOT graph format" 82 | , Option [] ["version"] 83 | (NoArg (\ opts -> opts { optVersion = True })) 84 | "Print version information" 85 | ] 86 | 87 | readArg :: Read a => String -> String -> a 88 | readArg optname arg = 89 | case reads arg of 90 | [(v,"")] -> v 91 | _ -> error $ "unrecognised value '" ++ arg 92 | ++ "' for option --" ++ optname 93 | 94 | main :: IO () 95 | main = 96 | do 97 | plainArgs <- getArgs 98 | let (optMods, args, errs) = getOpt Permute options plainArgs 99 | let opts = foldl (flip ($)) defaultOptions optMods 100 | case (args, errs) of 101 | _ | optVersion opts -> printVersion 102 | | optDecisionTree opts 103 | , Nothing <- optStartTime opts 104 | -> exit ["In --decision-tree mode, --start-time= is required"] 105 | 106 | ([contract], []) -> visualise opts contract output 107 | where output = replaceExtension contract 108 | (outputExtension (optMode opts)) 109 | ([contract, output], []) -> visualise opts contract output 110 | _ -> exit errs 111 | 112 | 113 | exit :: [String] -> IO () 114 | exit errs = do 115 | p <- getProgName 116 | let output | null errs = usageInfo usage options 117 | | otherwise = p ++ ": " ++ unlines errs 118 | ++ usageInfo usage options 119 | usage = "Usage: " ++ p ++ " []\n\nFlags:" 120 | putStrLn output 121 | exitFailure 122 | 123 | 124 | printVersion :: IO () 125 | printVersion = do 126 | p <- getProgName 127 | putStrLn $ "netrium " ++ p ++ " version " ++ showVersion version 128 | 129 | 130 | visualise :: Options -> FilePath -> FilePath -> IO () 131 | visualise opts contractFile outputFile = do 132 | 133 | contract <- fReadXml contractFile 134 | 135 | let tree | optDecisionTree opts 136 | , Just startTime <- optStartTime opts 137 | = trimDepth (fromMaybe optDepthDefault (optDepth opts)) 138 | $ toTree (decisionTreeSimple startTime contract) 139 | 140 | | otherwise 141 | = maybe id trimDepth (optDepth opts) 142 | $ toTree contract 143 | 144 | case optMode opts of 145 | OutputDot -> writeFile outputFile (renderDotGraph tree) 146 | _ -> do 147 | tmpdir <- getTemporaryDirectory 148 | (tmpfile, htmp) <- openTempFile tmpdir "contract.dot" 149 | hPutStr htmp (renderDotGraph tree) 150 | hClose htmp 151 | let format = case optMode opts of 152 | OutputSvg -> "-Tsvg" 153 | OutputPng -> "-Tpng" 154 | exitcode <- rawSystem "dot" [format, "-o", outputFile, tmpfile] 155 | removeFile tmpfile 156 | exitWith exitcode 157 | -------------------------------------------------------------------------------- /doc/doc-index-C.html: -------------------------------------------------------------------------------- 1 | (Index - C)

Index - C

calcFeeCommon
calDaysOffsetCalendar
CalendarCalendar
calendarDaysOffsetCalendar
CalendarOffsetTimeCalendar
CalendarPeriodCalendar
CallOptionOptions
CashFlowType 
1 (Type/Class)Contract
2 (Data Constructor)Contract
ChoiceIdContract
chooserLegCommon
chooserNoteCommon
Commodity 
1 (Type/Class)Contract
2 (Data Constructor)Contract
commoditySpreadOptionOptions
commoditySwapSwaps
commoditySwingCommon
computedFeeCommon
CondContract
condContract
ConditionWindowOptions
condPrPricing
ConstObservable
ContractContract
convertDoubleCommon
CounterParty 
1 (Type/Class)Common
2 (Data Constructor)Common
creditDefaultSwapSwaps
CreditEventCredit
CrossMarketNettingAgreement 
1 (Type/Class)Common
2 (Data Constructor)Common
Currency 
1 (Type/Class)Contract
2 (Data Constructor)Contract
-------------------------------------------------------------------------------- /tool/Normalise.hs: -------------------------------------------------------------------------------- 1 | -- |Netrium is Copyright Anthony Waite, Dave Hewett, Shaun Laurens & Contributors 2009-2018, and files herein are licensed 2 | -- |under the MIT license, the text of which can be found in license.txt 3 | -- 4 | module Main where 5 | 6 | import ObservableDB 7 | import UnitsDB 8 | import Paths_netrium 9 | 10 | import Control.Monad (liftM, liftM2, when) 11 | import Data.Version 12 | import System.Environment (getArgs, getProgName) 13 | import System.Exit (exitFailure, exitWith, ExitCode(..)) 14 | import System.Directory (getTemporaryDirectory, canonicalizePath, removeFile) 15 | import System.IO (openTempFile, hPutStr, hClose) 16 | import System.Process (runProcess, waitForProcess) 17 | import System.FilePath ((), dropExtension, addExtension, takeDirectory) 18 | import System.Console.GetOpt 19 | import Text.XML.HaXml.XmlContent 20 | 21 | 22 | data Options = 23 | Options 24 | { optObsDBs :: [FilePath] 25 | , optUnitDBs :: [FilePath] 26 | , optImportDirs :: [FilePath] 27 | , optFast :: Bool 28 | , optVersion :: Bool 29 | } 30 | 31 | defaultOptions = 32 | Options 33 | { optObsDBs = [] 34 | , optUnitDBs = [] 35 | , optImportDirs = [] 36 | , optFast = False 37 | , optVersion = False 38 | } 39 | 40 | options :: [OptDescr (Options -> Options)] 41 | options = [Option [] ["obs-db"] 42 | (ReqArg (\ db opts -> opts { optObsDBs = db : optObsDBs opts }) "") 43 | "use the observable database " 44 | ,Option [] ["units-db"] 45 | (ReqArg (\ db opts -> opts { optUnitDBs = db : optUnitDBs opts }) "") 46 | "use the units (products, currencies etc) database " 47 | ,Option [] ["import-dir"] 48 | (ReqArg (\ db opts -> opts { optImportDirs = db : optImportDirs opts }) "DIR") 49 | "Allow contracts to import modules from this directory" 50 | ,Option [] ["fast"] 51 | (NoArg (\ opts -> opts { optFast = True })) 52 | "Generate the output XML quickly but without any nice formatting" 53 | ,Option [] ["version"] 54 | (NoArg (\ opts -> opts { optVersion = True })) 55 | "Print version information" 56 | ] 57 | 58 | main :: IO () 59 | main = 60 | do 61 | plainArgs <- getArgs 62 | let (optMods, args, errs) = getOpt Permute options plainArgs 63 | let opts = foldl (flip ($)) defaultOptions optMods 64 | case args of 65 | _ | optVersion opts -> printVersion 66 | [input] | null errs -> normalise opts input output 67 | where output = addExtension input "xml" 68 | [input, output] | null errs -> normalise opts input output 69 | _ -> exit 70 | 71 | exit :: IO () 72 | exit = 73 | do 74 | p <- getProgName 75 | let txt = "Usage: " ++ p ++ " [options] []\n\n" ++ 76 | "Flags:" 77 | putStrLn $ usageInfo txt options 78 | exitFailure 79 | 80 | printVersion :: IO () 81 | printVersion = 82 | do 83 | p <- getProgName 84 | putStrLn $ "netrium " ++ p ++ " version " ++ showVersion version 85 | 86 | 87 | getObservableDBs :: Options -> IO [ObservableDB] 88 | getObservableDBs = mapM fReadXml . optObsDBs 89 | 90 | getUnitsDBs :: Options -> IO [UnitsDB] 91 | getUnitsDBs = mapM fReadXml . optUnitDBs 92 | 93 | 94 | normalise :: Options -> FilePath -> FilePath -> IO () 95 | normalise opts input output = 96 | do 97 | tdir <- getTemporaryDirectory 98 | let cdir = case takeDirectory input of "" -> "."; dir -> dir 99 | 100 | -- read and process the various input files 101 | obsDBs <- getObservableDBs opts 102 | unitsDBs <- getUnitsDBs opts 103 | wrapper <- readFile =<< getDataFileName "normalise-wrapper.hs" 104 | contract <- readFile input 105 | absOutput <- canonicalizePath output 106 | 107 | -- write the temporary source file 108 | (fp, h) <- openTempFile tdir "norm.hs" 109 | hPutStr h $ generateContractProgram (optFast opts) 110 | obsDBs unitsDBs 111 | wrapper "normalise-wrapper.hs" 112 | contract input 113 | absOutput 114 | hClose h 115 | 116 | -- compile and run it 117 | ddir <- getDataDir 118 | let ghcargs = [ "-package", "netrium-" ++ showVersion version ] 119 | ++ [ "-i" ++ dir | dir <- ddir : optImportDirs opts ++ [cdir] ] 120 | args = map ("--ghc-arg="++) ghcargs ++ [fp] 121 | ph <- runProcess "runghc" args Nothing Nothing Nothing Nothing Nothing 122 | exit <- waitForProcess ph 123 | removeFile fp 124 | when (exit /= ExitSuccess) exitFailure 125 | 126 | 127 | generateContractProgram :: Bool 128 | -> [ObservableDB] -> [UnitsDB] 129 | -> String -> FilePath 130 | -> String -> FilePath 131 | -> FilePath 132 | -> String 133 | generateContractProgram fast obsDBs unitsDBs 134 | wrapper wrapperFile 135 | contract contractFile outputFile = 136 | unlines 137 | [ "-- This is a generated file; do not edit.\n" 138 | , "{-# LINE 1 " ++ show wrapperFile ++ " #-}" 139 | , wrapper 140 | 141 | , "{-# LINE 1 " ++ show contractFile ++ " #-}" 142 | , contract 143 | 144 | , "{-# LINE 1 \"observables database\" #-}" 145 | , unlines (map compileObservableDB obsDBs) 146 | 147 | , "{-# LINE 1 \"units database\" #-}" 148 | , unlines (map compileUnitsDB unitsDBs) 149 | 150 | , "{-# LINE 1 \"generated contract program\" #-}" 151 | , "entrypoint :: Contract" 152 | , "entrypoint = contract" 153 | , "main = writeFile " ++ show outputFile ++ " $ " ++ outputCode 154 | ] 155 | where 156 | outputCode 157 | | fast 158 | = "PP.renderStyle PP.style { PP.mode = PP.OneLineMode } $ " 159 | ++ "XML.PP.document $ XML.toXml False entrypoint" 160 | 161 | | otherwise 162 | = "XML.showXml False entrypoint" 163 | -------------------------------------------------------------------------------- /examples/WeatherContingent.contract: -------------------------------------------------------------------------------- 1 | 2 | contract = 3 | weatherContingentMonthLeg 4 | monthlyPremium buyersAggregateLimitAmount sellersAggregateLimitAmount 5 | notionalAmount dailyDeductable weatherIndex gasIndexStrikeLevel 6 | previousAggregatePayment 7 | dailySch calcDate 8 | where 9 | monthlyPremium = 10 10 | buyersAggregateLimitAmount = m 14.5 11 | sellersAggregateLimitAmount = m 11 12 | notionalAmount = k 330 13 | dailyDeductable = k 137.5 14 | gasIndexStrikeLevel = 80 15 | previousAggregatePayment = konst 0 16 | weatherIndex = [ 4.03, 4.02, 4.01 ] 17 | dailySch = [ date 2011 1 d | d <- [1..3] ] 18 | calcDate = date 2011 2 5 19 | 20 | m = (*1000000) 21 | k = (*1000) 22 | 23 | ----------------------------------------------------------------------- 24 | 25 | weatherContingentMonthLeg 26 | monthlyPremium buyersAggregateLimitAmount sellersAggregateLimitAmount 27 | notionalAmount dailyDeductable 28 | weatherIndexStrikeSchedule gasIndexStrikeLevel 29 | previousAggregatePayment 30 | dailySch calcDate = 31 | 32 | foldr daily monthEnd (zip dailySch weatherIndexStrikeSchedule) (konst 0) 33 | 34 | where 35 | daily (day, weatherIndexStrikeLevel) next dailyPaymentSum = 36 | when (at day) $ 37 | letin "dailyPaymentSum" 38 | (dailyPaymentSum 39 | %+ dailyPayment notionalAmount dailyDeductable 40 | weatherIndexStrikeLevel gasIndexStrikeLevel) 41 | (\dailyPaymentSum' -> next dailyPaymentSum') 42 | 43 | monthEnd dailyPaymentSum = 44 | when (at calcDate) $ 45 | financial paymentDue gbp cash 46 | 47 | where 48 | -- Aggregate Payment Amount: 49 | -- For a given Calculation Date, if the sum of the Daily Payment Amounts in 50 | -- the period from the Effective Date to the last Day of the month prior to 51 | -- such Calculation Date is: 52 | -- (i) positive, then the Aggregate Payment Amount will equal the minimum 53 | -- of; (a) the sum of the Daily Payment Amounts, and (b) the Buyer's 54 | -- Aggregate Limit Amount, or 55 | -- 56 | -- (ii) negative, then the Aggregate Payment Amount will equal the maximum 57 | -- of (a) the sum of the Daily Payment Amounts, and (b) the Seller's 58 | -- Aggregate Limit Amount multiplied by negative one. 59 | -- 60 | aggregatePayment = 61 | ifthen (dailyPaymentSum %>= konst 0) 62 | (min dailyPaymentSum (konst buyersAggregateLimitAmount)) 63 | (max dailyPaymentSum (konst sellersAggregateLimitAmount)) 64 | 65 | -- Payment Amount: 66 | -- On each Payment Date the Payment Amount will equal the Aggregate Payment 67 | -- Amount for the respective Calculation Date less the Aggregate Payment 68 | -- Amount for the previous Calculation Date apart from the first Payment 69 | -- Date where the Payment Amount will be the Aggregate Payment Amount. 70 | paymentAmount = aggregatePayment %- previousAggregatePayment 71 | 72 | paymentDue = 73 | -- If the Payment Amount is: 74 | -- (i) positive, and Payment Amount less the Monthly Premium is positive 75 | -- then Seller shall pay Buyer a sum equal to Payment Amount less 76 | -- the Monthly Premium in GBP, or 77 | ifthen (paymentAmount %> konst 0 78 | %&& (paymentAmount %- konst monthlyPremium) %>= konst 0) 79 | (negate (paymentAmount %- konst monthlyPremium)) $ 80 | 81 | -- (ii) positive, and Payment Amount less the Monthly Premium is negative 82 | -- then Buyer shall pay Seller a sum equal to Monthly Premium less 83 | -- the Payment Amount. 84 | ifthen (paymentAmount %> konst 0 85 | %&& (paymentAmount %- konst monthlyPremium) %< konst 0) 86 | (konst monthlyPremium %- paymentAmount) $ 87 | 88 | -- (iii) negative, then Buyer shall pay Seller an amount equal to the 89 | -- absolute value of the Payment Amount in GBP plus the Monthly 90 | -- Premium, or 91 | ifthen (paymentAmount %< konst 0) 92 | (abs (paymentAmount %+ konst monthlyPremium)) 93 | 94 | -- (iv) zero, the Buyer shall pay Seller the Monthly Premium. 95 | (konst monthlyPremium) 96 | 97 | 98 | dailyPayment notionalAmount dailyDeductable 99 | weatherIndexStrikeLevel gasIndexStrikeLevel = 100 | 101 | -- Daily Payment Amount: 102 | -- Where Daily Accrual Amount is positive the Daily Payment Amount due to 103 | -- the Buyer shall be calculated as follows: 104 | ifthen (dailyAccrual %> konst 0) 105 | -- Daily Payment Amount = 106 | -- Max ((Daily Accrual Amount - Daily Deductible),0) 107 | (max (dailyAccrual %- konst dailyDeductable) (konst 0)) 108 | 109 | -- Where Daily Accrual Amount is negative the Daily Payment Amount due to 110 | -- the Seller shall be calculated as follows: 111 | -- 112 | -- Daily Payment Amount = Daily Accrual Amount 113 | (negate dailyAccrual) 114 | 115 | where 116 | -- Daily Accrual Amount: 117 | dailyAccrual = 118 | -- If: 119 | -- Natural Gas Settlement Price < Natural Gas Index Strike Level 120 | ifthen 121 | (gas_settlement_price %< konst gasIndexStrikeLevel) 122 | -- Daily Accrual Amount shall be: 123 | -- 124 | -- Relevant Notional Amount 125 | -- * [Weather Index - Weather Index Strike Level] 126 | -- * [Natural Gas Index Strike Level - Natural Gas Settlement Price] 127 | (konst notionalAmount 128 | %* (weather_metro_grp_CWV %- konst weatherIndexStrikeLevel) 129 | %* (konst gasIndexStrikeLevel %- gas_settlement_price )) 130 | 131 | -- Where Relevant Notional Amount relates to the Notional Amount applicable 132 | -- to the month in which the relevant Daily Accrual Amount falls. 133 | -- 134 | -- A positive result is a Daily Accrual Amount in favour of the Buyer and 135 | -- a negative result is a Daily Accrual Amount in favour of the Seller. 136 | 137 | -- If: 138 | -- Natural Gas Settlement Price > or = Natural Gas Index Strike Level 139 | -- then, Daily Accrual Amount shall be zero. 140 | (konst 0) 141 | 142 | -------------------------------------------------------------------------------- /share/Swaps.hs: -------------------------------------------------------------------------------- 1 | -- |Netrium is Copyright Anthony Waite, Dave Hewett, Shaun Laurens & Contributors 2009-2018, and files herein are licensed 2 | -- |under the MIT license, the text of which can be found in license.txt 3 | -- 4 | -- Module for swap contracts 5 | module Swaps where 6 | 7 | import Prelude hiding (and, or, min, max, abs, negate, not, read, until) 8 | import Contract 9 | import Common 10 | import Calendar 11 | import Credit 12 | 13 | import Data.List (transpose) 14 | import Data.Time 15 | import Data.Monoid 16 | 17 | -- | Basic commodity swap: simultaneous swap of commodity A for commodity B for 18 | -- a nominal cost over a delivery schedule (same cost for each delivery period) 19 | commoditySwap :: (Market, Market) 20 | -> (Volume, Volume) 21 | -> Price -> Currency -> CashFlowType 22 | -> Schedule 23 | -> Contract 24 | commoditySwap (market1, market2) (vol1, vol2) pr cur cft sch = 25 | scheduled (physical vol1 market1 `and` give (physical vol2 market2 `and` (financial pr cur cft))) sch 26 | 27 | -- | Variance swap 28 | -- 29 | -- A variance swap is an instrument which allows investors to trade future 30 | -- realized (or historical) volatility against current implied volatility. 31 | -- Only variance —the squared volatility— can be replicated with a static 32 | -- hedge. 33 | varianceSwap :: Price -- ^Notional amount 34 | -> Obs Double -- ^Vega amount 35 | -> Obs Double -- ^Variance amount 36 | -> Schedule -- ^Observation schedule 37 | -> Index -- ^Placeholder for index, currently not used 38 | -> [Price] -- ^Official closing prices of the underlying over the observation period 39 | -> Currency -- ^Payment currency 40 | -> CashFlowType -- ^Payment cashflow type 41 | -> DiffDateTime -- ^Settlement offset 42 | -> Calendar -- ^Calendar to use 43 | -> Contract 44 | varianceSwap strikePrice vegaAmount varianceAmount sch underlyingIndex priceCurve cur cft sDiffTime cal = 45 | when (at settlementTime) $ 46 | -- If the Equity Amount is negative the Variance Buyer will 47 | -- pay the Variance Seller an amount equal to the absolute 48 | --value of the Equity Amount 49 | cond (finalEquityAmount %<= konst 0) 50 | (give (financial (abs(finalEquityAmount)) cur cft)) 51 | -- If the Equity Amount is positive the Variance Seller will pay 52 | -- the Variance Buyer the Equity Amount 53 | (financial finalEquityAmount cur cft) 54 | 55 | where 56 | settlementTime = last(sch) `adjustDateTime` sDiffTime 57 | finalEquityAmount = varianceAmount * (square(finalRealisedVolatility) - square(strikePrice)) 58 | finalRealisedVolatility :: Price 59 | finalRealisedVolatility = 60 | 100 * sqrt ((252 * sumLnPt priceCurve) / fromIntegral numBusinessDays) 61 | where 62 | numBusinessDays = length $ calendarDaysInPeriod cal (head sch, last sch) 63 | 64 | -- Function needed to calculate the final realised volatility 65 | sumLnPt :: [Price] -> Price 66 | sumLnPt [] = 0 67 | sumLnPt [x] = 0 68 | sumLnPt (x1:x2:xs) = square(logBase (exp 1) (x2 / x1)) + sumLnPt (x2:xs) 69 | 70 | -- | Index Amortising Swap 71 | -- 72 | -- Swap Buyer receives the following coupons: 73 | -- Buyer rate paid e.g. quarterly (according to specified day count convention) 74 | -- on the principal amount, amortised according to the values of the buyer rate 75 | -- 76 | -- Swap Seller receives seller rate on same coupon dates. 77 | indexAmortisingSwap :: Price -- ^Notional amount 78 | -> Schedule -- ^Coupon dates 79 | -> (Currency, Currency) -- ^Currencies respectively for swap buyer and seller 80 | -> (CashFlowType, CashFlowType) -- ^Cashflow types respectively for cash buyer and seller 81 | -> AmortisationTable -- ^Amortisation table 82 | -> DayCountConvention -- ^Day count convention, e.g. 90/360 83 | -> Index -- ^Buyer rate 84 | -> Index -- ^Seller rate 85 | -> Contract 86 | indexAmortisingSwap notional cSch (cur1, cur2) (cft1, cft2) amTable dcc bRate sRate = 87 | foldr cAmt zero cSch 88 | 89 | where 90 | -- need to ensure fixing date is two days before coupon date 91 | cAmt cDate next = when (at cDate) $ allOf [cCalc, next] 92 | where 93 | cCalc = allOf[ 94 | financial (getAmRate bRate amTable %* notional %* konst dcc) cur1 cft1, 95 | give $ financial (sRate %* notional %* konst dcc) cur2 cft2 96 | ] 97 | 98 | -- |Credit Default Swap 99 | -- 100 | -- CDS buyer pays an agreed rate on an agreed basis on the principal amount 101 | -- 102 | -- CDS seller makes capital payments if and when credit events happen 103 | creditDefaultSwap :: [CreditEvent] -- ^List of credit events 104 | -> Price -- ^Notional amount 105 | -> Schedule -- ^Payment schedule 106 | -> Currency -- ^Payment currency 107 | -> Index -- ^Payment rate 108 | -> CashFlowType -- ^Payment cashflow type 109 | -> DayCountConvention -- ^Day count convention, e.g. 90/360 110 | -> Underlying -- ^Underlying asset 111 | -> Contract 112 | creditDefaultSwap cEvents notional cSch cur pRate cft dcc underlying = 113 | and 114 | -- CDS buyer pays an agreed rate on an agreed basis on the principal amount 115 | -- First, check if any credit events that would cause a termination of the contract has happened 116 | (cond(terminContract cEvents) 117 | zero 118 | (foldr cAmt zero cSch)) 119 | 120 | -- CDS seller makes capital payments if and when credit events happen 121 | (foldr capPay zero cEvents) 122 | 123 | where 124 | cAmt cDate next = when (at cDate) $ allOf [(financial (pRate %* notional %* konst dcc) cur cft), next] 125 | capPay (_, cTermin, sType, capPay, cCur, cHasHappened) next = when (cHasHappened) $ allOf[ 126 | (if (sType == 'C') 127 | then (give (financial capPay cCur (CashFlowType "cash"))) 128 | else (give underlying)) 129 | , next] 130 | -------------------------------------------------------------------------------- /share/ScheduledProduct.hs: -------------------------------------------------------------------------------- 1 | -- |Netrium is Copyright Anthony Waite, Dave Hewett, Shaun Laurens & Contributors 2009-2018, and files herein are licensed 2 | -- |under the MIT license, the text of which can be found in license.txt 3 | -- 4 | -- Scheduled products: products delivered according to a schedule. 5 | -- 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | module ScheduledProduct ( 8 | 9 | -- * Scheduled products 10 | ScheduledProduct, 11 | scheduledProduct, 12 | 13 | -- ** Defining scheduled products 14 | defineScheduledProduct, 15 | DeliverySchedule, 16 | deliverySchedule, 17 | 18 | -- ** Delivery shape 19 | DeliveryShape, 20 | deliverAtMidnight, 21 | deliverAtTimeOfDay, 22 | complexDeliveryShape, 23 | 24 | -- * Relative scheduled product type 25 | ScheduledProductRelative, 26 | scheduledProductRelative, 27 | setScheduledProductDate, 28 | defineScheduledProductRelative, 29 | DeliveryScheduleRelative, 30 | relativeDeliverySchedule, 31 | 32 | ) where 33 | 34 | import Contract 35 | import Common 36 | import Calendar 37 | 38 | import Data.Monoid 39 | 40 | 41 | -- | A scheduled product is a contract to repeatedly acquire a quantity of an 42 | -- underlying product according to a delivery schedule. 43 | -- 44 | -- Use 'productQuantity' to acquire a scheduled product and specify the 45 | -- quantity of the underlying product to recieve each time. 46 | -- 47 | data ScheduledProduct q = ScheduledProduct (q -> Contract) DeliverySchedule 48 | 49 | -- | A relative product is a product using a relative delivery schedule. 50 | -- Use 'setProductDate' to fix the delivery schedule. 51 | -- 52 | data ScheduledProductRelative q = ScheduledProductRelative (q -> Contract) DeliveryScheduleRelative 53 | 54 | -- | A delivery schedule for some product. 55 | -- 56 | -- This is an absolute schedule (e.g. June 2011, which delivers 57 | -- from 01/06/2011 to 30/06/2011 according to a given calendar). 58 | -- 59 | newtype DeliverySchedule 60 | = DeliverySchedule 61 | [([DateTime] -- delivery days 62 | , DateTime -- start date 63 | , DateTime -- end date 64 | ,DeliveryShape 65 | )] 66 | deriving Monoid 67 | 68 | -- | A relative delivery schedule for some product. 69 | -- 70 | -- This is a relative schedule (e.g. day ahead, month + 1, balance of month... 71 | -- - once again according to a given calendar). 72 | -- 73 | newtype DeliveryScheduleRelative 74 | = DeliveryScheduleRelative 75 | [(DiffDateTime -- start date/time relative to acquire 76 | ,DiffDateTime -- end date/time relative to acquire 77 | ,Calendar -- delivery days 78 | ,DeliveryShape 79 | )] 80 | deriving Monoid 81 | 82 | -- | The daily delivery shape says how often and when during the day the 83 | -- product is acquired. 84 | -- 85 | -- The simple cases are once daily at midnight using 'deliverAtMidnight', or 86 | -- once daily at a particular time of day using 'deliverAtTimeOfDay'. 87 | -- 88 | -- Complex delivery shapes can be constructed by combining multiple 89 | -- deliveries using the '(<>)' operator, or by using 'complexDeliveryShape'. 90 | -- 91 | -- For exmple, two daily deliveries, 6am and 6pm: 92 | -- 93 | -- > deliverAtTimeOfDay 6 0 <> deliverAtTimeOfDay 18 0 94 | -- 95 | -- Or, half-hourly delivery between 7am and 7pm: 96 | -- 97 | -- > complexDeliveryShape [ deliverAtTimeOfDay hr ms | hr <- [7..18], ms <- [0,30] ] 98 | -- 99 | newtype DeliveryShape = DeliveryShape [DiffDateTime] 100 | deriving Monoid 101 | 102 | 103 | -- | A contract to acquire a scheduled product using a given quantity of the 104 | -- underlying product. 105 | -- 106 | scheduledProduct :: q -> ScheduledProduct q -> Contract 107 | scheduledProduct quantity (ScheduledProduct underlying (DeliverySchedule blocks)) 108 | = allOf 109 | [ when (at t) (underlying quantity) 110 | | (days, _, _, DeliveryShape deliverySegments) <- blocks 111 | , day <- days 112 | , offset <- deliverySegments 113 | , let t = adjustDateTime day offset ] 114 | 115 | -- | A contract to acquire a relative scheduled product at a given date using a 116 | -- given quantity of the underlying product. 117 | -- 118 | scheduledProductRelative :: DateTime -> q -> ScheduledProductRelative q -> Contract 119 | scheduledProductRelative acquireDate quantity product = 120 | scheduledProduct quantity (setScheduledProductDate acquireDate product) 121 | 122 | -- | Turn a product with a relative schedule into a product with an 123 | -- absolute schedule. 124 | -- 125 | setScheduledProductDate :: DateTime -> ScheduledProductRelative q -> ScheduledProduct q 126 | setScheduledProductDate acquireDate 127 | (ScheduledProductRelative p (DeliveryScheduleRelative relShedule)) 128 | = ScheduledProduct p $ DeliverySchedule 129 | [ (days, startDate, endDate, shape) 130 | | (startOffset, endOffset, cal, shape) <- relShedule 131 | , let startDate = adjustDateTime acquireDate startOffset 132 | endDate = adjustDateTime acquireDate endOffset 133 | days = calendarDaysInPeriod cal (startDate, endDate) 134 | ] 135 | 136 | 137 | -- | Define a scheduled product based on an underlying contract to acquire a 138 | -- given quantity of a product. 139 | -- 140 | defineScheduledProduct :: (q -> Contract) -> DeliverySchedule -> ScheduledProduct q 141 | defineScheduledProduct = ScheduledProduct 142 | 143 | -- | Define a scheduled product with a schedule that is relative to some date. 144 | -- 145 | defineScheduledProductRelative :: (q -> Contract) -> DeliveryScheduleRelative -> ScheduledProductRelative q 146 | defineScheduledProductRelative = ScheduledProductRelative 147 | 148 | 149 | -- | Define a delivery schedule using absolute dates. 150 | -- 151 | -- A delivery schedule with multiple different blocks can be defined by 152 | -- combining schedules by using the '(<>)' operator. 153 | -- 154 | deliverySchedule :: DateTime -> DateTime 155 | -> Calendar -- ^ What days to deliver on 156 | -> DeliveryShape 157 | -> DeliverySchedule 158 | deliverySchedule start end cal shape = 159 | DeliverySchedule [(days, start, end, shape)] 160 | where 161 | days = calendarDaysInPeriod cal (start, end) 162 | 163 | -- | Define a delivery schedule using dates relative to the acquisition date. 164 | -- 165 | -- A delivery schedule with multiple different blocks can be defined by 166 | -- combining schedules by using the '(<>)' operator. 167 | -- 168 | relativeDeliverySchedule :: DiffDateTime -> DiffDateTime 169 | -> Calendar -- ^ What days to deliver on 170 | -> DeliveryShape 171 | -> DeliveryScheduleRelative 172 | relativeDeliverySchedule start end cal shape = 173 | DeliveryScheduleRelative [(start, end, cal, shape)] 174 | 175 | 176 | -- | Single delivery at midnight. 177 | -- 178 | deliverAtMidnight :: DeliveryShape 179 | deliverAtMidnight = deliverAtTimeOfDay 0 0 180 | 181 | -- | Single delivery at a particular time of day. 182 | -- 183 | deliverAtTimeOfDay :: Int -> Int -> DeliveryShape 184 | deliverAtTimeOfDay hs ms = DeliveryShape [atTimeOfDay hs ms] 185 | 186 | -- | Defines a complex intra-day delivery shape as a sequence of deliveries. 187 | -- 188 | -- For exmple, half-hourly delivery between 7am and 7pm: 189 | -- 190 | -- > complexDeliveryShape [ deliverAtTimeOfDay hr ms | hr <- [7..18], ms <- [0,30] ] 191 | -- 192 | complexDeliveryShape :: [DeliveryShape] -> DeliveryShape 193 | complexDeliveryShape = mconcat 194 | --------------------------------------------------------------------------------