{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Contract (
Contract(..),
zero, one,
and, give, party,
or, cond,
scale, ScaleFactor,
when, anytime, until,
read, letin,
Tradeable(..),
Commodity(..), Unit(..), Location(..), Duration(..),
Currency(..), CashFlowType(..), Portfolio(..),
ChoiceId, PartyName,
Obs,
konst, var, primVar, primCond,
Time,
at, before, after, between,
ifthen, negate, max, min, abs,
(%==),
(%>), (%>=), (%<), (%<=),
(%&&), (%||),
(%+), (%-), (%*), (%/),
) where
import Observable
( Time, mkdate
, Obs, konst, var, primVar, primCond, at, before, after, between
, (%==), (%>), (%>=), (%<), (%<=)
, (%&&), (%||), (%+), (%-), (%*), (%/)
, ifthen, negate, not, max, min, abs
, parseObsCond, parseObsReal, printObs )
import Display
import XmlUtils
import Prelude hiding (product, read, until, and, or, min, max, abs, not, negate)
import Control.Monad hiding (when)
import Text.XML.HaXml.Namespaces (localName)
import Text.XML.HaXml.Types (QName(..))
import Text.XML.HaXml.XmlContent
data Tradeable = Physical Commodity Unit Location (Maybe Duration) (Maybe Portfolio)
| Financial Currency CashFlowType (Maybe Portfolio)
deriving (Eq, Show)
newtype Duration = Duration Int deriving (Eq, Show, Num)
newtype Commodity = Commodity String deriving (Eq, Show)
newtype Unit = Unit String deriving (Eq, Show)
newtype Location = Location String deriving (Eq, Show)
newtype Currency = Currency String deriving (Eq, Show)
newtype CashFlowType = CashFlowType String deriving (Eq, Show)
newtype Portfolio = Portfolio String deriving (Eq, Show)
type ScaleFactor = Double
type ChoiceId = String
type PartyName = String
data Contract
= Zero
| One Tradeable
| Give Contract
| Party PartyName Contract
| And Contract Contract
| Or ChoiceId Contract Contract
| Cond (Obs Bool) Contract Contract
| Scale (Obs Double) Contract
| Read Var (Obs Double) Contract
| When (Obs Bool) Contract
| Anytime ChoiceId (Obs Bool) Contract
| Until (Obs Bool) Contract
deriving (Eq, Show)
type Var = String
zero :: Contract
zero = Zero
one :: Tradeable -> Contract
one = One
give :: Contract -> Contract
give = Give
party :: PartyName -> Contract -> Contract
party = Party
and :: Contract -> Contract -> Contract
and = And
or :: ChoiceId -> Contract -> Contract -> Contract
or = Or
cond :: Obs Bool -> Contract -> Contract -> Contract
cond = Cond
scale :: Obs ScaleFactor -> Contract -> Contract
scale = Scale
read :: Var -> Obs Double -> Contract -> Contract
read = Read
{-# DEPRECATED read "Use 'letin' instead." #-}
when :: Obs Bool -> Contract -> Contract
when = When
anytime :: ChoiceId -> Obs Bool -> Contract -> Contract
anytime = Anytime
until :: Obs Bool -> Contract -> Contract
until = Until
letin :: String
-> Obs Double
-> (Obs Double -> Contract)
-> Contract
letin vname obs c = read vname obs (c (var vname))
instance Display Contract where
toTree Zero = Node "zero" []
toTree (One t) = Node "one" [Node (show t) []]
toTree (Give c) = Node "give" [toTree c]
toTree (Party p c) = Node ("party " ++ p)[toTree c]
toTree (And c1 c2) = Node "and" [toTree c1, toTree c2]
toTree (Or cid c1 c2) = Node ("or " ++ cid) [toTree c1, toTree c2]
toTree (Cond o c1 c2) = Node "cond" [toTree o, toTree c1, toTree c2]
toTree (Scale o c) = Node "scale" [toTree o, toTree c]
toTree (Read n o c) = Node ("read " ++ n) [toTree o, toTree c]
toTree (When o c) = Node "when" [toTree o, toTree c]
toTree (Anytime cid o c) = Node ("anytime" ++ cid) [toTree o, toTree c]
toTree (Until o c) = Node "until" [toTree o, toTree c]
instance HTypeable Tradeable where
toHType _ = Defined "Tradeable" [] []
instance XmlContent Tradeable where
parseContents = do
e@(Elem t _ _) <- element ["Physical","Financial"]
commit $ interior e $ case localName t of
"Physical" -> liftM5 Physical parseContents parseContents
parseContents parseContents
parseContents
"Financial" -> liftM3 Financial parseContents parseContents
parseContents
toContents (Physical c u l d p) =
[mkElemC "Physical" (toContents c ++ toContents u
++ toContents l ++ toContents d
++ toContents p)]
toContents (Financial c t p) =
[mkElemC "Financial" (toContents c ++ toContents t
++ toContents p)]
instance HTypeable Duration where
toHType _ = Defined "Duration" [] []
instance XmlContent Duration where
parseContents = inElement "Duration" (liftM Duration readText)
toContents (Duration sec) = [mkElemC "Duration" (toText (show sec))]
instance HTypeable Commodity where
toHType _ = Defined "Commodity" [] []
instance XmlContent Commodity where
parseContents = inElement "Commodity" (liftM Commodity text)
toContents (Commodity name) = [mkElemC "Commodity" (toText name)]
instance HTypeable Unit where
toHType _ = Defined "Unit" [] []
instance XmlContent Unit where
parseContents = inElement "Unit" (liftM Unit text)
toContents (Unit name) = [mkElemC "Unit" (toText name)]
instance HTypeable Location where
toHType _ = Defined "Location" [] []
instance XmlContent Location where
parseContents = inElement "Location" (liftM Location text)
toContents (Location name) = [mkElemC "Location" (toText name)]
instance HTypeable Currency where
toHType _ = Defined "Currency" [] []
instance XmlContent Currency where
parseContents = inElement "Currency" (liftM Currency text)
toContents (Currency name) = [mkElemC "Currency" (toText name)]
instance HTypeable CashFlowType where
toHType _ = Defined "CashFlowType" [] []
instance XmlContent CashFlowType where
parseContents = inElement "CashFlowType" (liftM CashFlowType text)
toContents (CashFlowType name) = [mkElemC "CashFlowType" (toText name)]
instance HTypeable Portfolio where
toHType _ = Defined "Portfolio" [] []
instance XmlContent Portfolio where
parseContents = inElement "Portfolio" (liftM Portfolio text)
toContents (Portfolio name) = [mkElemC "Portfolio" (toText name)]
instance HTypeable Contract where
toHType _ = Defined "Contract" [] []
instance XmlContent Contract where
parseContents = do
e@(Elem t _ _) <- element ["Zero","When","Until","Scale","Read"
,"Or","One","Give","Party","Cond","Anytime","And"]
commit $ interior e $ case localName t of
"Zero" -> return Zero
"One" -> liftM One parseContents
"Give" -> liftM Give parseContents
"Party" -> liftM2 Party (attrStr (N "name") e) parseContents
"And" -> liftM2 And parseContents parseContents
"Or" -> liftM3 Or (attrStr (N "choiceid") e) parseContents parseContents
"Cond" -> liftM3 Cond parseObsCond parseContents parseContents
"Scale" -> liftM2 Scale parseObsReal parseContents
"Read" -> liftM3 Read (attrStr (N "var") e) parseObsReal parseContents
"When" -> liftM2 When parseObsCond parseContents
"Anytime" -> liftM3 Anytime (attrStr (N "choiceid") e) parseObsCond parseContents
"Until" -> liftM2 Until parseObsCond parseContents
toContents Zero = [mkElemC "Zero" []]
toContents (One t) = [mkElemC "One" (toContents t)]
toContents (Give c) = [mkElemC "Give" (toContents c)]
toContents (Party p c) = [mkElemAC (N "Party") [(N "name", str2attr p)]
(toContents c)]
toContents (And c1 c2) = [mkElemC "And" (toContents c1 ++ toContents c2)]
toContents (Or cid c1 c2) = [mkElemAC (N "Or") [(N "choiceid", str2attr cid)]
(toContents c1 ++ toContents c2)]
toContents (Cond o c1 c2) = [mkElemC "Cond" (printObs o : toContents c1 ++ toContents c2)]
toContents (Scale o c) = [mkElemC "Scale" (printObs o : toContents c)]
toContents (Read n o c) = [mkElemAC (N "Read") [(N "var", str2attr n)]
(printObs o : toContents c)]
toContents (When o c) = [mkElemC "When" (printObs o : toContents c)]
toContents (Anytime cid o c) = [mkElemAC (N "Anytime") [(N "choiceid", str2attr cid)]
(printObs o : toContents c)]
toContents (Until o c) = [mkElemC "Until" (printObs o : toContents c)]