-- |Netrium is Copyright Anthony Waite, Dave Hetwett, Shaun Laurens 2009-2015, and files herein are licensed
-- |under the MIT license,  the text of which can be found in license.txt
--
-- The definition of the basic contract language
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Contract (
    -- * Contracts
    -- ** The contract type and primitives
    Contract(..),
    zero, one,
    and, give, party,
    or, cond,
    scale, ScaleFactor,
    when, anytime, until,
    read, letin,

    -- ** Tradable items
    Tradeable(..),
    Commodity(..), Unit(..), Location(..), Duration(..),
    Currency(..), CashFlowType(..), Portfolio(..),

    -- ** Choice identifiers
    ChoiceId, PartyName,

    -- * Observables
    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

-- * Contract type definition
-- | A canonical tradeable element, physical or financial
data Tradeable = Physical  Commodity Unit Location (Maybe Duration) (Maybe Portfolio)
               | Financial Currency CashFlowType (Maybe Portfolio)
  deriving (Eq, Show)

-- | A duration is a span of time, measured in seconds.
--
newtype Duration  = Duration  Int {- in sec -} deriving (Eq, Show, Num)
-- | Commodity, e.g. Gas, Electricity
newtype Commodity = Commodity String           deriving (Eq, Show)
-- | Unit, e.g. tonnes, MWh
newtype Unit      = Unit      String           deriving (Eq, Show)
-- | Location, e.g. UK, EU
newtype Location  = Location  String           deriving (Eq, Show)
-- | Currency, e.g. EUR, USD, GBP
newtype Currency  = Currency  String           deriving (Eq, Show)
-- | Cashflow type, e.g. cash, premium
newtype CashFlowType = CashFlowType String     deriving (Eq, Show)
-- | Portfolio name
newtype Portfolio = Portfolio String           deriving (Eq, Show)

-- | Scaling factor (used to scale the 'One' contract)
type ScaleFactor  = Double

-- | Choice label, used for options
type ChoiceId = String

-- | Name of a third party mentioned in a contract
type PartyName = String

-- | The main contract data type
--
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)

-- | A variable
type Var = String

-- | The @zero@ contract has no rights and no obligations.
zero :: Contract
zero = Zero

-- | If you acquire @one t@ you immediately recieve one unit of the
-- 'Tradeable' @t@.
one :: Tradeable -> Contract
one = One

-- | Swap the rights and obligations of the party and counterparty.
give :: Contract -> Contract
give = Give

-- | Make a contract with a named 3rd party as the counterparty.
party :: PartyName -> Contract -> Contract
party = Party

-- | If you acquire @c1 `and` c2@ you immediately acquire /both/ @c1@ and @c2@.
and :: Contract -> Contract -> Contract
and = And

-- | If you acquire @c1 `or` c2@ you immediately acquire your choice of
-- /either/ @c1@ or @c2@.
or :: ChoiceId -> Contract -> Contract -> Contract
or = Or
--TODO: document the ChoiceId

-- | If you acquire @cond obs c1 c2@ then you acquire @c1@ if the observable
-- @obs@ is true /at the moment of acquistion/, and @c2@ otherwise.
cond :: Obs Bool -> Contract -> Contract -> Contract
cond = Cond

-- | If you acquire @scale obs c@, then you acquire @c@ at the same moment
-- except that all the subsequent trades of @c@ are multiplied by the value
-- of the observable @obs@ /at the moment of acquistion/.
scale :: Obs ScaleFactor -> Contract -> Contract
scale = Scale

read :: Var -> Obs Double -> Contract -> Contract
read = Read
{-# DEPRECATED read "Use 'letin' instead." #-}

-- | If you acquire @when obs c@, you must acquire @c@ as soon as observable
-- @obs@ subsequently becomes true.
when :: Obs Bool -> Contract -> Contract
when = When

-- | Once you acquire @anytime obs c@, you /may/ acquire @c@ at any time the
-- observable @obs@ is true.
anytime :: ChoiceId -> Obs Bool -> Contract -> Contract
anytime = Anytime

-- | Once acquired, @until obs c@ is exactly like @c@ except that it /must be
-- abandoned/ when observable @obs@ becomes true.
until :: Obs Bool -> Contract -> Contract
until = Until


-- | Observe the value of an observable now and save its value to use later.
--
-- Currently this requires a unique variable name.
--
-- Example:
--
-- > letin "count" (count-1) $ \count' ->
-- >   ...
--
letin :: String                    -- ^ A unique variable name
      -> Obs Double                -- ^ The observable to observe now
      -> (Obs Double -> Contract)  -- ^ The contract using the observed value
      -> Contract
letin vname obs c = read vname obs (c (var vname))


-- Display tree instances
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]

-- XML instances
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)]