Commit 3681f0b6 authored by Bas Lijnse's avatar Bas Lijnse

Miscellaneous improvements. Mostly reimplementing of old types using the new style GUI.

git-svn-id: https://svn.cs.ru.nl/repos/iTask-system/branches/fancyTasks@586 63da3aa8-80fd-4f01-9db8-e6ea747a3da2
parent 57bda917
......@@ -16,6 +16,7 @@ import DelegateTask
import ReviewTask
//Miscellaneous examples
import BugReport
import Coffeemachine
import Newsgroups
import ExceptionHandling
......@@ -37,6 +38,7 @@ where
, deadlineTaskExample
, delegateTaskExample
, reviewTaskExample
, bugReportExample
, coffeemachineExample
, newsgroupsExample
, exceptionHandlingExample
......
......@@ -66,19 +66,19 @@ selectSuppliers
[(label, return supplier) \\ supplier =: (uid, label) <- suppliers]
)
collectBids :: Purchase [(Int,String)] -> Task [((Int,String),Money)]
collectBids :: Purchase [(Int,String)] -> Task [((Int,String),Currency)]
collectBids purchase suppliers
= andTasksEnough
[("Bid for " +++ purchase.Purchase.name +++ " from " +++ name, uid @: ("Bid request regarding " +++ purchase.Purchase.name, collectBid purchase supplier)) \\ supplier =: (uid,name) <- suppliers]
where
collectBid :: Purchase (Int,String) -> Task ((Int,String),Money)
collectBid :: Purchase (Int,String) -> Task ((Int,String),Currency)
collectBid purchase bid
= [Text "Please make a bid to supply the following product"]
?>>
(displayValue purchase -||- (editTask "Ok" createDefault >>= \price -> return (bid, price)) <<@ TTVertical)
selectBid :: [((Int,String),Money)] -> Task ((Int,String),Money)
selectBid :: [((Int,String),Currency)] -> Task ((Int,String),Currency)
selectBid bids
= determineCheapest bids >>= \cheapestBid =: ((uid,name),price) ->
[ Text "The cheapest bid is ", Text (toString price), Text " by ", Text name, BrTag [],
......@@ -95,7 +95,7 @@ where
determineCheapest bids = return (hd (sortBy (\(_,x) (_,y) -> x < y) bids))
yesOrNo = (editTask "Yes" Void >>| return True) -||- (editTask "No" Void >>| return False)
confirmBid :: Purchase ((Int,String),Money) -> Task Void
confirmBid :: Purchase ((Int,String),Currency) -> Task Void
confirmBid purchase bid =: ((uid,label),price)
= uid @: ("Bid confirmation",(
[Text "Your bid of ", Text (toString price),Text " for the product ",ITag [] [Text purchase.Purchase.name], Text " has been accepted."]
......
......@@ -54,4 +54,4 @@ where
BookHotel = editTask "BookHotel" ("Hotel Name " ,"", "Costs ",DefCosts)
BookCar = editTask "BookCar" ("Car Brand " ,"", "Costs ",DefCosts)
DefCosts = Money EUR 0
DefCosts = EUR 0
......@@ -13,7 +13,7 @@ derive gPrint QForm, Person, Gender
, endDate :: Date
, estimatedHours :: Int
, description :: Note
, price :: Money
, price :: Currency
}
:: Person = { firstName :: String
, surname :: String
......
......@@ -30,7 +30,7 @@ derive gUpdate QForm, Review, Person, Gender
, endDate :: Date
, estimatedHours :: Int
, description :: Note
, price :: Money
, price :: Currency
}
:: Person = { firstName :: String
, surname :: String
......
definition module BugReport
/**
* Simple bug reporting and tracking example.
* Used in IFL2009 paper
*/
import iTasks
bugReportExample :: [Workflow]
\ No newline at end of file
implementation module BugReport
import iTasks
bugReportExample :: [Workflow]
bugReportExample = []
\ No newline at end of file
......@@ -9,6 +9,7 @@ implementation module Coffeemachine
// Some alternative coffee machine definitions have been added as example for the ICFP07 paper.
import iTasks
import CommonDomain
coffeemachineExample :: [Workflow]
coffeemachineExample = [{ name = "Examples/Miscellaneous/Coffeemachine"
......@@ -16,35 +17,37 @@ coffeemachineExample = [{ name = "Examples/Miscellaneous/Coffeemachine"
, roles =[]
, mainTask =(forever coffeemachine) >>| return Void
}]
coffeemachine :: Task (String,Int)
coffeemachine
= chooseTask [Text "Choose product:",Br,Br]
[("Coffee: 100", return (100,"Coffee"))
,("Cappucino: 150", return (150,"Cappucino"))
,("Tea: 50", return (50, "Tea"))
,("Chocolate: 100", return (100,"Chocolate"))
coffeemachine :: Task (String,Currency)
coffeemachine = requestChoice "Choose product"
[("Coffee", EUR 100)
,("Cappucino", EUR 150)
,("Tea", EUR 50)
,("Chocolate", EUR 100)
]
>>= \(toPay,product) -> [Text ("Chosen product: " <+++ product),Br,Br]
?>> getCoins (toPay,0)
>>= \(product,toPay) -> getCoins product (toPay,EUR 0)
>>= \(cancel,returnMoney) ->let nproduct = if cancel "Cancelled" product in
[Text ("product = " <+++ nproduct <+++ ", returned money = " <+++ returnMoney),Br,Br]
?>> buttonTask "Thanks" (return (nproduct,returnMoney))
showMessage ("product = " <+++ nproduct <+++ ", returned money = " <+++ returnMoney)
>>| return (nproduct,returnMoney)
getCoins :: (Int,Int) -> Task (Bool,Int)
getCoins (cost,paid) = getCoins`
getCoins :: String (Currency,Currency) -> Task (Bool,Currency)
getCoins product (cost,paid) = getCoins`
where
getCoins`
= requestChoice ("To pay: " <+++ cost) coins >>= \c -> return (False,c)
= (requestChoice [ Text ("Chosen product: " <+++ product), BrTag[]
, BrTag []
, Text ("To pay: " <+++ cost), BrTag []
, Text "Please insert a coin..."
] coins >>= \c -> return (False,c))
-||-
buttonTask "Cancel" (return (True,0))
((requestConfirmation "...or do you want to stop and get your money back?" <! id )>>| return (True, EUR 0))
>>= handleMoney
handleMoney (cancel,coin)
| cancel = return (cancel, paid)
| cost > coin = getCoins (cost-coin,paid+coin)
| otherwise = return (cancel, coin-cost)
coins = [5,10,20,50,100,200]
| cancel = return (cancel, paid)
| cost > coin = getCoins product (cost-coin,paid+coin)
| otherwise = return (cancel, coin-cost)
coins = [EUR 5,EUR 10,EUR 20,EUR 50,EUR 100,EUR 200]
// getCoins2 is alternative definition of getCoins, but uses repeatTask instead of direct recursion
......
......@@ -10,7 +10,7 @@ class InCart a | nameOf, priceOf, amountOrderedOf a
:: Book = { id_ :: !DBRef Book
, title :: !String
, author :: !String
, price :: !Money
, price :: !Currency
, inStock :: !Int
}
:: Cart item :== [CartItem item]
......@@ -18,7 +18,7 @@ class InCart a | nameOf, priceOf, amountOrderedOf a
, name :: !String
, inStock :: !Int
, amountOrdered :: !Int
, price :: !Money
, price :: !Currency
}
:: CartAmount = { orderAmount :: !Int
}
......@@ -35,7 +35,7 @@ class InCart a | nameOf, priceOf, amountOrderedOf a
}
:: InCart = { name :: !String
, amountOrdered :: !Int
, price :: !Money
, price :: !Currency
}
:: ShopAction = LeaveShop | ToCart | ToPay | ToShop
......@@ -51,5 +51,5 @@ instance DB Book
instance DB (Order a)
eqItemNr :: !(CartItem item) !(CartItem item) -> Bool
totalCost :: [a] -> Money | priceOf, amountOrderedOf a
totalCost :: [a] -> Currency | priceOf, amountOrderedOf a
shopOwner :: UserId
......@@ -37,8 +37,8 @@ defaultCart = createDefault
eqItemNr :: !(CartItem a) !(CartItem a) -> Bool
eqItemNr x y = x.itemNr == y.itemNr
totalCost :: [a] -> Money | priceOf, amountOrderedOf a
totalCost set = Money EUR (sum [amountOrderedOf item * toInt (priceOf item) \\ item <- set])
totalCost :: [a] -> Currency | priceOf, amountOrderedOf a
totalCost set = EUR (sum [amountOrderedOf item * toInt (priceOf item) \\ item <- set])
shopOwner :: UserId
shopOwner = 0
......@@ -15,7 +15,7 @@ class shippingAddressOf a :: a -> Address
class amountOrderedOf a :: a -> Int
class nameOf a :: a -> String
class id_Of a :: a -> DBRef a
class priceOf a :: a -> Money
class priceOf a :: a -> Currency
class inStockOf a :: a -> Int
class billingAddressUpd a :: a Address -> a
......@@ -23,7 +23,7 @@ class shippingAddressUpd a :: a Address -> a
class amountOrderedUpd a :: a Int -> a
class nameUpd a :: a String -> a
class id_Upd a :: a (DBRef a) -> a
class priceUpd a :: a Money -> a
class priceUpd a :: a Currency -> a
class inStockUpd a :: a Int -> a
instance id_Of Book; instance id_Upd Book
......
......@@ -12,9 +12,12 @@ import CommonDomain
:: Person =
{ name :: String
, cool :: Bool
, dob :: Date
, tob :: Time
, age :: Maybe Int
, address :: Address
, grades :: [Int]
, note :: Note
}
derive gPrint Person, Address
......@@ -22,11 +25,11 @@ derive gParse Person, Address
derive gVisualize Person, Address
derive gUpdate Person, Address
myPerson = {name = "Bas", cool = True, address = myAddress, age = Just 25, grades = []}
myPerson = {name = "Bas", cool = True, dob = {Date | year = 1984, mon = 1, day = 13}, tob = {Time| hour= 8, min = 23, sec = 0}, address = myAddress, age = Just 25, grades = [], note = Note ""}
myAddress = {street = "Berg en Dalseweg", number = 24, postalCode = "6521JG"}
Start :: *World -> *World
Start world = startEngine [workflow "GUI test" guiTestTask] world
guiTestTask :: Task Void
guiTestTask = requestChoice "Pick a number" [1,2,3] >>| return Void
\ No newline at end of file
guiTestTask = requestInformationWD "Please update your personal information" myPerson >>| return Void
\ No newline at end of file
......@@ -28,23 +28,28 @@ import StdString
}
// Money
:: Money = Money Currency Int // Type of currency and amount in cents
:: Currency // A selection of ISO4217 currency codes
= EUR
| GBP
| USD
| JPY
:: Currency // Type of currency and amount in cents. ISO4217 currency codes are used
= EUR Int
| GBP Int
| USD Int
| JPY Int
derive gPrint EmailAddress, Password, Note, Date, Time, Money, Currency
derive gParse EmailAddress, Password, Note, Date, Time, Money, Currency
derive gVisualize EmailAddress, Password, Note, Date, Time, Money, Currency
derive gUpdate EmailAddress, Password, Note, Date, Time, Money, Currency
derive gPrint EmailAddress, Password, Note, Date, Time, Currency
derive gParse EmailAddress, Password, Note, Date, Time, Currency
derive gVisualize EmailAddress, Password, Note, Date, Time, Currency
derive gUpdate EmailAddress, Password, Note, Date, Time, Currency
instance toString Money
instance toString Date
instance toString Time
instance toString Currency
instance toInt Money
instance toInt Currency
instance < Money
instance + Money
instance zero Money
\ No newline at end of file
instance fromString Date
instance fromString Time
instance < Currency
instance + Currency
instance - Currency
instance zero Currency
\ No newline at end of file
implementation module CommonDomain
import iTasks
import StdOverloaded, StdClass, StdInt, StdMisc, StdArray
import GenPrint, GenParse, GenLexOrd, GUICore
import GUICore
derive gPrint EmailAddress, Password, Note, Date, Time, Money, Currency
derive gParse EmailAddress, Password, Note, Date, Time, Money, Currency
derive gVisualize EmailAddress, Password, Note, Date, Time, Money, Currency
derive gUpdate EmailAddress, Password, Note, Date, Time, Money, Currency
derive gLexOrd Money, Currency
derive gPrint EmailAddress, Password, Note, Date, Time, Currency
derive gParse EmailAddress, Password, Note, Date, Time, Currency
derive gVisualize EmailAddress, Password
derive gUpdate EmailAddress, Password, Note, Currency
derive gLexOrd Currency
instance toString Money
gVisualize{|Date|} old new vst=:{vizType,label,idPrefix,dataPath}
= case vizType of
VEditorDefinition = ([ExtJSFragment (ExtJSDateField {ExtJSDateField|name = dp2s dataPath, id = dp2id idPrefix dataPath, value = toString old, format = "d-m-Y", fieldLabel = label})], {VSt|vst & dataPath = stepDataPath dataPath})
_ = ([TextFragment (toString old)],{vst & dataPath = stepDataPath dataPath})
gVisualize{|Time|} old new vst=:{vizType,label,idPrefix,dataPath}
= case vizType of
VEditorDefinition = ([ExtJSFragment (ExtJSTimeField {ExtJSTimeField|name = dp2s dataPath, id = dp2id idPrefix dataPath, value = toString old, format = "H:i:s", fieldLabel = label})], {VSt|vst & dataPath = stepDataPath dataPath})
_ = ([TextFragment (toString old)],{vst & dataPath = stepDataPath dataPath})
gVisualize{|Note|} old new vst=:{vizType,label,idPrefix,dataPath}
= case vizType of
VEditorDefinition = ([ExtJSFragment (ExtJSTextArea {ExtJSTextArea|name = dp2s contentPath, id = dp2id idPrefix contentPath, value = toString old, fieldLabel = label, width = 400, height = 150 })], {VSt|vst & dataPath = stepDataPath dataPath})
_ = ([TextFragment (toString old)],{vst & dataPath = stepDataPath dataPath})
where
// Use the path to the inner constructor instead of the current path.
// This way the generic gUpdate will work for this type
contentPath = shiftDataPath dataPath
gVisualize{|Currency|} old new vst=:{vizType}
= case vizType of
//VEditorDefinition
_
= ([TextFragment (toString old)],vst)
gUpdate{|Date|} _ ust=:{USt|mode=UDCreate} = ({Date|year = 2000, mon = 1, day = 1}, ust)
gUpdate{|Date|} s ust=:{USt|mode=UDSearch,searchPath,currentPath,update}
| dp2s currentPath == searchPath
= (fromString update, {USt|ust & mode = UDDone})
| otherwise
= (s, {USt|ust & currentPath = stepDataPath currentPath})
gUpdate{|Date|} s ust = (s, ust)
gUpdate{|Time|} _ ust=:{USt|mode=UDCreate} = ({Time|hour = 0, min = 0, sec = 0}, ust)
gUpdate{|Time|} s ust=:{USt|mode=UDSearch,searchPath,currentPath,update}
| dp2s currentPath == searchPath
= (fromString update, {USt|ust & mode = UDDone})
| otherwise
= (s, {USt|ust & currentPath = stepDataPath currentPath})
gUpdate{|Time|} s ust = (s, ust)
instance toString Time
where
toString {Time|hour,min,sec} = (pad 2 hour) +++ ":" +++ (pad 2 min) +++ ":" +++ (pad 2 sec)
instance fromString Time
where
fromString s = {Time|hour = toInt (s %(0,1)), min = toInt (s %(3,4)), sec = toInt (s %(6,7)) }
instance toString Date
where
toString {Date|year,mon,day} = (pad 2 day) +++ "-" +++ (pad 2 mon) +++ "-" +++ (pad 4 year)
instance fromString Date
where
fromString s = {Date|day = toInt (s %(0,1)), mon = toInt (s %(3,4)), year = toInt (s %(6,9))}
instance toString Note
where
toString x = visualizeAsTextLabel x
toString (Note s) = s
instance toString Currency
where
toString x = visualizeAsTextLabel x
toString (EUR x) = "EUR " +++ decFormat x
toString (GBP x) = "GBP " +++ decFormat x
toString (USD x) = "USD " +++ decFormat x
toString (JPY x) = "JPY " +++ decFormat x
instance toInt Money
instance toInt Currency
where
toInt (Money _ val) = val
toInt (EUR val) = val
toInt (GBP val) = val
toInt (USD val) = val
toInt (JPY val) = val
instance < Money
instance < Currency
where
(<) x y = case x =?= y of
LT = True
_ = False
instance zero Money
instance zero Currency
where
zero = EUR 0
instance + Currency
where
zero = Money EUR 0
(+) (EUR x) (EUR y) = EUR (x + y)
(+) (GBP x) (GBP y) = GBP (x + y)
(+) (USD x) (USD y) = USD (x + y)
(+) (JPY x) (JPY y) = JPY (x + y)
(+) _ _ = abort "Trying to add money of different currencies!"
instance + Money
instance - Currency
where
(+) (Money curx valx) (Money cury valy) = (Money curx (valx + valy)) //Never add different currencies!
\ No newline at end of file
(-) (EUR x) (EUR y) = EUR (x - y)
(-) (GBP x) (GBP y) = GBP (x - y)
(-) (USD x) (USD y) = USD (x - y)
(-) (JPY x) (JPY y) = JPY (x - y)
(-) _ _ = abort "Trying to subtract money of different currencies!"
//Utility functions
pad :: Int Int -> String
pad len num = (createArray (max 0 (len - size nums)) '0' ) +++ nums
where
nums = toString num
decFormat :: Int -> String
decFormat x = toString (x / 100) +++ "." +++ pad 2 (x rem 100)
\ No newline at end of file
......@@ -21,13 +21,13 @@ derive JSONEncode ExtJSDef, ExtJSUpdate
| ExtJSButton ExtJSButton
| ExtJSNumberField ExtJSNumberField
| ExtJSTextField ExtJSTextField
| ExtJSTextArea
| ExtJSTextArea ExtJSTextArea
| ExtJSComboBox
| ExtJSCheckBox ExtJSCheckBox
| ExtJSRadio ExtJSRadio
| ExtJSRadioGroup ExtJSRadioGroup
| ExtJSTimeField
| ExtJSDateField
| ExtJSTimeField ExtJSTimeField
| ExtJSDateField ExtJSDateField
| ExtJSHtmlEditor
| ExtJSFieldSet ExtJSFieldSet
| ExtJSPanel ExtJSPanel
......@@ -40,7 +40,6 @@ derive JSONEncode ExtJSDef, ExtJSUpdate
, value :: String
, iconCls :: String
}
:: ExtJSNumberField =
{ name :: String
, id :: String
......@@ -54,6 +53,14 @@ derive JSONEncode ExtJSDef, ExtJSUpdate
, value :: String
, fieldLabel :: Maybe String
}
:: ExtJSTextArea =
{ name :: String
, id :: String
, value :: String
, fieldLabel :: Maybe String
, width :: Int
, height :: Int
}
:: ExtJSCheckBox =
{ name :: String
, id :: String
......@@ -74,6 +81,20 @@ derive JSONEncode ExtJSDef, ExtJSUpdate
, fieldLabel :: Maybe String
, items :: [ExtJSDef]
}
:: ExtJSDateField =
{ name :: String
, id :: String
, value :: String
, format :: String
, fieldLabel :: Maybe String
}
:: ExtJSTimeField =
{ name :: String
, id :: String
, value :: String
, format :: String
, fieldLabel :: Maybe String
}
:: ExtJSFieldSet =
{ title :: String
, id :: String
......
......@@ -2,15 +2,18 @@ implementation module ExtJS
import JSON
//JSON Encoding of ExtJS definitions is directly encoded as ExtJS JSON data.
derive JSONEncode ExtJSButton, ExtJSTextField, ExtJSNumberField, ExtJSCheckBox, ExtJSRadio, ExtJSRadioGroup, ExtJSFieldSet, ExtJSPanel, ExtJSHtmlPanel
derive JSONEncode ExtJSButton, ExtJSTextField, ExtJSTextArea, ExtJSNumberField, ExtJSCheckBox, ExtJSRadio, ExtJSRadioGroup, ExtJSDateField, ExtJSTimeField, ExtJSFieldSet, ExtJSPanel, ExtJSHtmlPanel
derive JSONEncode ExtJSUpdate
JSONEncode{|ExtJSDef|} (ExtJSButton r) c = addXType "button" (JSONEncode{|*|} r c)
JSONEncode{|ExtJSDef|} (ExtJSTextField r) c = addXType "textfield" (JSONEncode{|*|} r c)
JSONEncode{|ExtJSDef|} (ExtJSTextArea r) c = addXType "textarea" (JSONEncode{|*|} r c)
JSONEncode{|ExtJSDef|} (ExtJSNumberField r) c = addXType "numberfield" (JSONEncode{|*|} r c)
JSONEncode{|ExtJSDef|} (ExtJSCheckBox r) c = addXType "checkbox" (JSONEncode{|*|} r c)
JSONEncode{|ExtJSDef|} (ExtJSRadio r) c = addXType "radio" (JSONEncode{|*|} r c)
JSONEncode{|ExtJSDef|} (ExtJSRadioGroup r) c = addXType "radiogroup" (JSONEncode{|*|} r c)
JSONEncode{|ExtJSDef|} (ExtJSDateField r) c = addXType "datefield" (JSONEncode{|*|} r c)
JSONEncode{|ExtJSDef|} (ExtJSTimeField r) c = addXType "timefield" (JSONEncode{|*|} r c)
JSONEncode{|ExtJSDef|} (ExtJSFieldSet r) c = addXType "fieldset" (JSONEncode{|*|} r c)
JSONEncode{|ExtJSDef|} (ExtJSPanel r) c = addXType "panel" (JSONEncode{|*|} r c)
JSONEncode{|ExtJSDef|} (ExtJSHtmlPanel r) c = addXType "panel" (JSONEncode{|*|} r c)
......
......@@ -79,4 +79,13 @@ updateValue :: String String a -> a | gUpdate{|*|} a
| HtmlFragment [HtmlTag]
| ExtJSFragment ExtJSDef
| ExtJSUpdate ExtJSUpdate
\ No newline at end of file
//Utility functions making specializations of gVisualize
dp2s :: DataPath -> String
dp2id :: String DataPath -> String
isdps :: String -> Bool
stepDataPath :: DataPath -> DataPath
shiftDataPath :: DataPath -> DataPath
dataPathLevel :: DataPath -> Int
......@@ -20,13 +20,13 @@ visualizeAsHtmlDisplay :: a -> [HtmlTag] | gVisualize{|*|} a
visualizeAsHtmlDisplay x = []
visualizeAsTextDisplay :: a -> String | gVisualize{|*|} a
visualizeAsTextDisplay x = join "" (coerceToStrings (fst (gVisualize{|*|} x x {mkVSt & vizType = VTextDisplay})))
visualizeAsTextDisplay x = join " " (coerceToStrings (fst (gVisualize{|*|} x x {mkVSt & vizType = VTextDisplay})))
visualizeAsHtmlLabel :: a -> [HtmlTag] | gVisualize{|*|} a
visualizeAsHtmlLabel x = []
visualizeAsTextLabel :: a -> String | gVisualize{|*|} a
visualizeAsTextLabel x = join "" (coerceToStrings (fst (gVisualize{|*|} x x {mkVSt & vizType = VTextLabel})))
visualizeAsTextLabel x = join " " (coerceToStrings (fst (gVisualize{|*|} x x {mkVSt & vizType = VTextLabel})))