Commit 55e5eb7b authored by Bas Lijnse's avatar Bas Lijnse

Updated iTasks libraries to use new Generics representation.

IMPORTANT!
- Make sure you use the latest iTask compiler (automatically with iTask environment)
- Replace your copy of StdGeneric in StdEnv with the version from the "iTasks-SDK/Compiler" folder. 

git-svn-id: https://svn.cs.ru.nl/repos/iTask-system/trunk@2062 63da3aa8-80fd-4f01-9db8-e6ea747a3da2
parent 65c5386a
This diff was suppressed by a .gitattributes entry.
No preview for this file type
...@@ -2,7 +2,7 @@ implementation module CommonCombinators ...@@ -2,7 +2,7 @@ implementation module CommonCombinators
/** /**
* This module contains a collection of useful iTasks combinators defined in terms of the basic iTask combinators * This module contains a collection of useful iTasks combinators defined in terms of the basic iTask combinators
*/ */
import StdBool, StdList,StdOrdList, StdTuple, StdGeneric, StdMisc, StdInt, StdClass, GenRecord, Text, Time, Tuple, List import StdBool, StdList,StdOrdList, StdTuple, StdGeneric, StdMisc, StdInt, StdClass, GenRecord, Text, Time, Tuple, List_NG
import Util, Either, GenVisualize, GenUpdate import Util, Either, GenVisualize, GenUpdate
from StdFunc import id, const, o from StdFunc import id, const, o
from SystemTypes import :: User(..), :: Note(..) from SystemTypes import :: User(..), :: Note(..)
......
implementation module DBTasks implementation module DBTasks
import StdList, StdOrdList, Util, List import StdList, StdOrdList, Util, List_NG
import iTaskClass, Task, Shared import iTaskClass, Task, Shared
from CoreTasks import get, set, return from CoreTasks import get, set, return
from CommonCombinators import >>|, >>= from CommonCombinators import >>|, >>=
......
...@@ -3,7 +3,7 @@ implementation module InteractionTasks ...@@ -3,7 +3,7 @@ implementation module InteractionTasks
from StdFunc import id, const, o, flip from StdFunc import id, const, o, flip
from SystemData import null from SystemData import null
from Tuple import appSnd from Tuple import appSnd
from List import isMemberGen, instance Functor [] from List_NG import isMemberGen, instance Functor []
from Time import :: Timestamp(..) from Time import :: Timestamp(..)
import StdBool, StdList, StdMisc, StdTuple import StdBool, StdList, StdMisc, StdTuple
......
implementation module CoreCombinators implementation module CoreCombinators
import StdList, StdTuple, StdMisc, StdBool, StdOrdList import StdList, StdTuple, StdMisc, StdBool, StdOrdList
import Task, TaskState, TaskStore, TaskEval, Util, HTTP, GenUpdate, GenEq, Store, SystemTypes, Time, Text, Shared, Func, Tuple, List import Task, TaskState, TaskStore, TaskEval, Util, HTTP, GenUpdate, GenEq_NG, Store, SystemTypes, Time, Text, Shared, Func, Tuple, List_NG
import iTaskClass, InteractionTasks, LayoutCombinators, TUIDefinition import iTaskClass, InteractionTasks, LayoutCombinators, TUIDefinition
from Map import qualified get, put, del from Map import qualified get, put, del
......
implementation module CoreTasks implementation module CoreTasks
import StdList, StdBool, StdInt, StdTuple,StdMisc, Util, HtmlUtil, Time, Error, OSError, Map, Tuple, List import StdList, StdBool, StdInt, StdTuple,StdMisc, Util, HtmlUtil, Time, Error, OSError, Map, Tuple, List_NG
import qualified StdList import qualified StdList
import iTaskClass, Task, TaskState, TaskEval, TaskStore, TUIDefinition, LayoutCombinators, Shared import iTaskClass, Task, TaskState, TaskEval, TaskStore, TUIDefinition, LayoutCombinators, Shared
from SharedDataSource import qualified read, write from SharedDataSource import qualified read, write
......
...@@ -2,7 +2,7 @@ implementation module IntegrationTasks ...@@ -2,7 +2,7 @@ implementation module IntegrationTasks
import StdInt, StdFile, StdTuple, StdList import StdInt, StdFile, StdTuple, StdList
import Directory, File, FilePath, Error, OSError, UrlEncoding, Text, Tuple, JSON import Directory, File, FilePath, Error, OSError, UrlEncoding, Text, Tuple, JSON_NG
import SystemTypes, IWorld, Task, TaskState import SystemTypes, IWorld, Task, TaskState
import LayoutCombinators import LayoutCombinators
......
...@@ -3,7 +3,7 @@ definition module SystemData ...@@ -3,7 +3,7 @@ definition module SystemData
* This module provides access to the iTask framework data by means of * This module provides access to the iTask framework data by means of
* a set of shared data structures. * a set of shared data structures.
*/ */
import Maybe, JSON, Shared import Maybe, JSON_NG, Shared
from SystemTypes import :: DateTime, :: Date, :: Time, :: User, :: Role, :: TaskList, :: Tree from SystemTypes import :: DateTime, :: Date, :: Time, :: User, :: Role, :: TaskList, :: Tree
from SystemTypes import :: TaskListItem, :: Config, :: TaskId, :: TaskNo, :: InstanceNo, :: SharedTaskList from SystemTypes import :: TaskListItem, :: Config, :: TaskId, :: TaskNo, :: InstanceNo, :: SharedTaskList
from Void import :: Void from Void import :: Void
......
...@@ -4,7 +4,7 @@ definition module SystemTypes ...@@ -4,7 +4,7 @@ definition module SystemTypes
* of the iTasks framework. * of the iTasks framework.
*/ */
import GenEq, Maybe, JSON, Store, Void, Either, FilePath, HTML, Error, File, OS import GenEq_NG, Maybe, JSON_NG, Store, Void, Either, FilePath, HTML, Error, File, OS
from Map import :: Map from Map import :: Map
from Map import qualified get from Map import qualified get
from HTML import class html from HTML import class html
......
implementation module SystemTypes implementation module SystemTypes
from StdFunc import until from StdFunc import until
import StdInt, StdBool, StdClass, StdArray, StdTuple, StdMisc, StdList, StdFunc, StdOrdList, List, dynamic_string, Base64 import StdInt, StdBool, StdClass, StdArray, StdTuple, StdMisc, StdList, StdFunc, StdOrdList, List_NG, dynamic_string, Base64
import GenLexOrd, JSON, HTML, Text, Util import JSON_NG, HTML, Text, Util
from Time import :: Timestamp(..) from Time import :: Timestamp(..)
from Task import :: TaskValue from Task import :: TaskValue
......
implementation module GoogleMaps implementation module GoogleMaps
import HTML, StdEnv, JSON, GenUpdate, GenVisualize, GenVerify import HTML, StdEnv, JSON_NG, GenUpdate, GenVisualize, GenVerify
derive JSONEncode TUIGoogleMap, TUIGoogleMapOptions derive JSONEncode TUIGoogleMap, TUIGoogleMapOptions
derive JSONDecode MVCUpdate, ClickUpdate, ClickSource, ClickEvent, MarkerDragUpdate derive JSONDecode MVCUpdate, ClickUpdate, ClickSource, ClickEvent, MarkerDragUpdate
......
...@@ -4,7 +4,7 @@ definition module Engine ...@@ -4,7 +4,7 @@ definition module Engine
* This is the primary function that creates the complete * This is the primary function that creates the complete
* environment in which worfklow specifications can be executed. * environment in which worfklow specifications can be executed.
*/ */
import Maybe, JSON, FilePath, Task, StdList import Maybe, JSON_NG, FilePath, Task, StdList
from IWorld import :: IWorld from IWorld import :: IWorld
from HTTP import :: HTTPRequest, :: HTTPResponse from HTTP import :: HTTPRequest, :: HTTPResponse
......
...@@ -34,13 +34,13 @@ generic gPutRecordFields r :: !r ![GenType] !*RecordFields -> (!r,!*RecordFields ...@@ -34,13 +34,13 @@ generic gPutRecordFields r :: !r ![GenType] !*RecordFields -> (!r,!*RecordFields
:: *RecordFields :: *RecordFields
derive gGetRecordFields UNIT, PAIR, EITHER, CONS, OBJECT, FIELD derive gGetRecordFields UNIT, PAIR, EITHER, CONS, OBJECT, RECORD, FIELD
derive gGetRecordFields Int, Real, Char, Bool, String derive gGetRecordFields Int, Real, Char, Bool, String
derive gGetRecordFields Dynamic, [], Maybe, Either, (,), (,,), (,,,), (->), Void, Display, Editable, Hidden, VisualizationHint, Timestamp derive gGetRecordFields Dynamic, [], Maybe, Either, (,), (,,), (,,,), (->), Void, Display, Editable, Hidden, VisualizationHint, Timestamp
derive gGetRecordFields Note, Password, Date, Time, DateTime, Document, FormButton, EUR, USD, User, RadioChoice, CheckMultiChoice, Map, TreeChoice, Tree, TreeNode, HtmlTag, HtmlAttr derive gGetRecordFields Note, Password, Date, Time, DateTime, Document, FormButton, EUR, USD, User, RadioChoice, CheckMultiChoice, Map, TreeChoice, Tree, TreeNode, HtmlTag, HtmlAttr
derive gGetRecordFields EmailAddress, Action derive gGetRecordFields EmailAddress, Action
derive gPutRecordFields UNIT, PAIR, EITHER, CONS, OBJECT, FIELD derive gPutRecordFields UNIT, PAIR, EITHER, CONS, OBJECT, RECORD, FIELD
derive gPutRecordFields Int, Real, Char, Bool, String derive gPutRecordFields Int, Real, Char, Bool, String
derive gPutRecordFields Dynamic, [], Maybe, Either, (,), (,,), (,,,), (->), Void, Display, Editable, Hidden, VisualizationHint, Timestamp derive gPutRecordFields Dynamic, [], Maybe, Either, (,), (,,), (,,,), (->), Void, Display, Editable, Hidden, VisualizationHint, Timestamp
derive gPutRecordFields Note, Password, Date, Time, DateTime, Document, FormButton, EUR, USD, User, RadioChoice, CheckMultiChoice, Map, TreeChoice, Tree, TreeNode, HtmlTag, HtmlAttr derive gPutRecordFields Note, Password, Date, Time, DateTime, Document, FormButton, EUR, USD, User, RadioChoice, CheckMultiChoice, Map, TreeChoice, Tree, TreeNode, HtmlTag, HtmlAttr
......
implementation module GenRecord implementation module GenRecord
import StdTuple, StdList, StdFunc, Error, Util, GenUpdate, Map, Generic, Tuple import StdTuple, StdList, StdFunc, Error, Util, GenUpdate, Map, Generic_NG, Tuple
from dynamic_string import copy_to_string, copy_from_string from dynamic_string import copy_to_string, copy_from_string
copyRecord :: !a !b -> b | GenRecord a & GenRecord b copyRecord :: !a !b -> b | GenRecord a & GenRecord b
...@@ -15,9 +15,7 @@ mapRecord rec ...@@ -15,9 +15,7 @@ mapRecord rec
generic gGetRecordFields r :: !r ![GenType] !*RecordFields -> *RecordFields generic gGetRecordFields r :: !r ![GenType] !*RecordFields -> *RecordFields
gGetRecordFields{|OBJECT of d|} fx (OBJECT o) _ fields gGetRecordFields{|OBJECT of d|} fx (OBJECT o) _ fields = fields
| isRecordType d = fx o (getFieldTypes d) fields
| otherwise = fields
gGetRecordFields{|CONS|} fx (CONS c) types fields = fx c types fields gGetRecordFields{|CONS|} fx (CONS c) types fields = fx c types fields
gGetRecordFields{|EITHER|} fx fy either types fields = case either of gGetRecordFields{|EITHER|} fx fy either types fields = case either of
LEFT x = fx x types fields LEFT x = fx x types fields
...@@ -25,6 +23,7 @@ gGetRecordFields{|EITHER|} fx fy either types fields = case either of ...@@ -25,6 +23,7 @@ gGetRecordFields{|EITHER|} fx fy either types fields = case either of
gGetRecordFields{|PAIR|} fx fy (PAIR x y) types fields gGetRecordFields{|PAIR|} fx fy (PAIR x y) types fields
# fields = fx x types fields # fields = fx x types fields
= fy y types fields = fy y types fields
gGetRecordFields{|RECORD of d|} fx (RECORD r) _ fields = fx r (getFieldTypes d) fields
gGetRecordFields{|FIELD of d|} _ f types fields = put d.gfd_name (GenericDyn (copy_to_string f) (types !! d.gfd_index)) fields gGetRecordFields{|FIELD of d|} _ f types fields = put d.gfd_name (GenericDyn (copy_to_string f) (types !! d.gfd_index)) fields
gGetRecordFields{|UNIT|} _ _ fields = fields gGetRecordFields{|UNIT|} _ _ fields = fields
gGetRecordFields{|Int|} _ _ fields = fields gGetRecordFields{|Int|} _ _ fields = fields
...@@ -41,9 +40,7 @@ derive gGetRecordFields EmailAddress, Action, ButtonState ...@@ -41,9 +40,7 @@ derive gGetRecordFields EmailAddress, Action, ButtonState
generic gPutRecordFields r :: !r ![GenType] !*RecordFields -> (!r,!*RecordFields) generic gPutRecordFields r :: !r ![GenType] !*RecordFields -> (!r,!*RecordFields)
gPutRecordFields{|OBJECT of d|} fx obj=:(OBJECT o) _ fields gPutRecordFields{|OBJECT of d|} fx obj=:(OBJECT o) _ fields = (obj,fields)
| isRecordType d = appFst OBJECT (fx o (getFieldTypes d) fields)
| otherwise = (obj,fields)
gPutRecordFields{|CONS|} fx (CONS c) types fields = appFst CONS (fx c types fields) gPutRecordFields{|CONS|} fx (CONS c) types fields = appFst CONS (fx c types fields)
gPutRecordFields{|EITHER|} fx fy either types fields = case either of gPutRecordFields{|EITHER|} fx fy either types fields = case either of
LEFT x = appFst LEFT (fx x types fields) LEFT x = appFst LEFT (fx x types fields)
...@@ -52,6 +49,8 @@ gPutRecordFields{|PAIR|} fx fy (PAIR x y) types fields ...@@ -52,6 +49,8 @@ gPutRecordFields{|PAIR|} fx fy (PAIR x y) types fields
# (x`,fields) = fx x types fields # (x`,fields) = fx x types fields
# (y`,fields) = fy y types fields # (y`,fields) = fy y types fields
= (PAIR x` y`,fields) = (PAIR x` y`,fields)
gPutRecordFields{|RECORD of d|} fx (RECORD r) _ fields
= appFst RECORD (fx r (getFieldTypes d) fields)
gPutRecordFields{|FIELD of d|} _ f types fields gPutRecordFields{|FIELD of d|} _ f types fields
# (mbGenDyn,fields) = delU d.gfd_name fields # (mbGenDyn,fields) = delU d.gfd_name fields
# f` = case mbGenDyn of # f` = case mbGenDyn of
...@@ -93,8 +92,8 @@ matchGenericDyn (GenericDyn str dynType) reqType ...@@ -93,8 +92,8 @@ matchGenericDyn (GenericDyn str dynType) reqType
| otherwise = Nothing | otherwise = Nothing
// Retrieves the types of a record's fields. // Retrieves the types of a record's fields.
getFieldTypes :: !GenericTypeDefDescriptor -> [GenType] getFieldTypes :: !GenericRecordDescriptor -> [GenType]
getFieldTypes {gtd_conses=c=:[{gcd_type}]} = getFieldTypes` gcd_type [] getFieldTypes {grd_type} = getFieldTypes` grd_type []
where where
getFieldTypes` (GenTypeArrow field next) acc = getFieldTypes` next [field:acc] getFieldTypes` (GenTypeArrow field next) acc = getFieldTypes` next [field:acc]
getFieldTypes` _ acc = reverse acc getFieldTypes` _ acc = reverse acc
......
...@@ -24,7 +24,7 @@ from Map import :: Map ...@@ -24,7 +24,7 @@ from Map import :: Map
generic gUpdate a :: !(UpdateMode a) !*USt -> (!a,!*USt) generic gUpdate a :: !(UpdateMode a) !*USt -> (!a,!*USt)
derive gUpdate UNIT, PAIR, EITHER, CONS, OBJECT, FIELD derive gUpdate UNIT, PAIR, EITHER, CONS, OBJECT, RECORD, FIELD
derive gUpdate Int, Real, Char, Bool, String derive gUpdate Int, Real, Char, Bool, String
derive gUpdate Dynamic, [], Maybe, Either, (,), (,,), (,,,), (->), JSONNode, Void, HtmlTag, Display, Editable, Hidden, VisualizationHint, Timestamp derive gUpdate Dynamic, [], Maybe, Either, (,), (,,), (,,,), (->), JSONNode, Void, HtmlTag, Display, Editable, Hidden, VisualizationHint, Timestamp
derive gUpdate Note, DateTime, Document, FormButton, Username, Password, EUR, USD, Date, Time, User, UserConstraint, RadioChoice, ComboChoice, GridChoice, DynamicChoice, CheckMultiChoice, Map, Tree, TreeChoice, TreeNode, Table derive gUpdate Note, DateTime, Document, FormButton, Username, Password, EUR, USD, Date, Time, User, UserConstraint, RadioChoice, ComboChoice, GridChoice, DynamicChoice, CheckMultiChoice, Map, Tree, TreeChoice, TreeNode, Table
...@@ -33,7 +33,7 @@ derive gUpdate ControlSize, FillControlSize, FillWControlSize, FillHControlSize ...@@ -33,7 +33,7 @@ derive gUpdate ControlSize, FillControlSize, FillWControlSize, FillHControlSize
generic gDefaultMask a :: !a -> [UpdateMask] generic gDefaultMask a :: !a -> [UpdateMask]
derive gDefaultMask UNIT, PAIR, EITHER, CONS, OBJECT, FIELD derive gDefaultMask UNIT, PAIR, EITHER, CONS, OBJECT, RECORD, FIELD
derive gDefaultMask Int, Real, Char, Bool, String derive gDefaultMask Int, Real, Char, Bool, String
derive gDefaultMask Dynamic, [], Maybe, Either, (,), (,,), (,,,), (->), JSONNode, Void, HtmlTag, Display, Editable, Hidden, VisualizationHint, Timestamp derive gDefaultMask Dynamic, [], Maybe, Either, (,), (,,), (,,,), (->), JSONNode, Void, HtmlTag, Display, Editable, Hidden, VisualizationHint, Timestamp
derive gDefaultMask Note, DateTime, Document, FormButton, Username, Password, EUR, USD, Date, Time, User, UserConstraint, RadioChoice, ComboChoice, GridChoice, DynamicChoice, CheckMultiChoice, Map, Tree, TreeChoice, TreeNode, Table derive gDefaultMask Note, DateTime, Document, FormButton, Username, Password, EUR, USD, Date, Time, User, UserConstraint, RadioChoice, ComboChoice, GridChoice, DynamicChoice, CheckMultiChoice, Map, Tree, TreeChoice, TreeNode, Table
......
implementation module GenUpdate implementation module GenUpdate
import StdString, StdBool, StdChar, StdList, StdArray, StdTuple, StdMisc, Maybe, StdGeneric, StdEnum, Tuple, List import StdString, StdBool, StdChar, StdList, StdArray, StdTuple, StdMisc, Maybe, StdGeneric, StdEnum, Tuple, List_NG
import SystemTypes, Text, Util, DocumentStore import SystemTypes, Text, Util, DocumentStore
from StdFunc import id, const, o from StdFunc import id, const, o
from TUIDefinition import :: TUISize(..), :: TUIFixedSize, :: TUIWeight from TUIDefinition import :: TUISize(..), :: TUIFixedSize, :: TUIWeight
...@@ -60,7 +60,20 @@ where ...@@ -60,7 +60,20 @@ where
JSONInt consIdx | consIdx < length d.gtd_conses JSONInt consIdx | consIdx < length d.gtd_conses
= getConsPath (d.gtd_conses !! consIdx) = getConsPath (d.gtd_conses !! consIdx)
_ = [] _ = []
gUpdate{|RECORD|} fx UDCreate ust=:{newMask}
# (nx,ust=:{newMask=recordMask}) = fx UDCreate {ust & newMask = []}
= (RECORD nx, {ust & newMask = newMask ++ recordMask})
gUpdate{|RECORD|} fx (UDSearch (RECORD x)) ust=:{searchPath,currentPath,update,oldMask,newMask}
# (cm,om) = popMask oldMask
| searchPath <== currentPath
//Update is targeted somewhere in a substructure of this value
# (nx,ust=:{newMask=childMask}) = fx (UDSearch x) {ust & currentPath = shiftDataPath currentPath, oldMask = childMasks cm, newMask = []}
= (RECORD nx, {ust & currentPath = stepDataPath currentPath, oldMask = om, newMask = appendToMask newMask (Touched childMask)})
| otherwise
//Not on the path, so just put back the current mask (cm)
= (RECORD x, {ust & currentPath = stepDataPath currentPath, oldMask = om, newMask = appendToMask newMask cm})
gUpdate{|CONS|} fx UDCreate ust = appFst CONS (fx UDCreate ust) gUpdate{|CONS|} fx UDCreate ust = appFst CONS (fx UDCreate ust)
gUpdate{|CONS|} fx (UDSearch (CONS c)) ust = appFst CONS (fx (UDSearch c) ust) gUpdate{|CONS|} fx (UDSearch (CONS c)) ust = appFst CONS (fx (UDSearch c) ust)
gUpdate{|FIELD|} fx UDCreate ust = appFst FIELD (fx UDCreate ust) gUpdate{|FIELD|} fx UDCreate ust = appFst FIELD (fx UDCreate ust)
...@@ -284,6 +297,7 @@ generic gDefaultMask a :: !a -> [UpdateMask] ...@@ -284,6 +297,7 @@ generic gDefaultMask a :: !a -> [UpdateMask]
gDefaultMask{|UNIT|} _ = [] gDefaultMask{|UNIT|} _ = []
gDefaultMask{|OBJECT|} fx (OBJECT x) = [Touched (fx x)] gDefaultMask{|OBJECT|} fx (OBJECT x) = [Touched (fx x)]
gDefaultMask{|CONS|} fx (CONS x) = fx x gDefaultMask{|CONS|} fx (CONS x) = fx x
gDefaultMask{|RECORD|} fx (RECORD x) = fx x
gDefaultMask{|FIELD|} fx (FIELD x) = fx x gDefaultMask{|FIELD|} fx (FIELD x) = fx x
gDefaultMask{|PAIR|} fx fy (PAIR x y) = fx x ++ fy y gDefaultMask{|PAIR|} fx fy (PAIR x y) = fx x ++ fy y
gDefaultMask{|EITHER|} fx fy e = case e of gDefaultMask{|EITHER|} fx fy e = case e of
......
...@@ -22,7 +22,7 @@ generic gVerify a :: !(Maybe a) !*VerSt -> *VerSt ...@@ -22,7 +22,7 @@ generic gVerify a :: !(Maybe a) !*VerSt -> *VerSt
instance GenMask VerifyMask instance GenMask VerifyMask
instance toString ErrorMessage instance toString ErrorMessage
derive gVerify UNIT, PAIR, EITHER, OBJECT, CONS, FIELD, Int, Real, Char, Bool, String, (,), (,,),(,,,),(->), [] derive gVerify UNIT, PAIR, EITHER, OBJECT, CONS, RECORD, FIELD, Int, Real, Char, Bool, String, (,), (,,),(,,,),(->), []
derive gVerify Maybe, Dynamic, JSONNode, Void, Document, Either, Editable, Hidden, Display, VisualizationHint, HtmlTag, Timestamp derive gVerify Maybe, Dynamic, JSONNode, Void, Document, Either, Editable, Hidden, Display, VisualizationHint, HtmlTag, Timestamp
derive gVerify Username, Password, Date, Time, FormButton, EUR, USD, User, Note, DateTime, RadioChoice, ComboChoice, GridChoice, DynamicChoice, CheckMultiChoice, Map, Tree, TreeChoice, TreeNode, Table derive gVerify Username, Password, Date, Time, FormButton, EUR, USD, User, Note, DateTime, RadioChoice, ComboChoice, GridChoice, DynamicChoice, CheckMultiChoice, Map, Tree, TreeChoice, TreeNode, Table
derive gVerify EmailAddress, Action, HtmlInclude, ManagementMeta, TaskPriority derive gVerify EmailAddress, Action, HtmlInclude, ManagementMeta, TaskPriority
......
implementation module GenVerify implementation module GenVerify
import StdGeneric, StdBool, StdInt, StdList, StdTuple, StdFunc, Maybe, Functor, Util, Text, Generic import StdGeneric, StdBool, StdInt, StdList, StdTuple, StdFunc, Maybe, Functor, Util, Text, Generic_NG
import GenUpdate, StdMisc import GenUpdate, StdMisc
derive gVerify (,), (,,), (,,,), Void, Either, DateTime, Timestamp, Map, EmailAddress, Action, TreeNode, UserConstraint, ManagementMeta, TaskPriority, Tree derive gVerify (,), (,,), (,,,), Void, Either, DateTime, Timestamp, Map, EmailAddress, Action, TreeNode, UserConstraint, ManagementMeta, TaskPriority, Tree
...@@ -23,6 +23,20 @@ generic gVerify a :: !(Maybe a) !*VerSt -> *VerSt ...@@ -23,6 +23,20 @@ generic gVerify a :: !(Maybe a) !*VerSt -> *VerSt
gVerify{|UNIT|} _ vst = vst gVerify{|UNIT|} _ vst = vst
gVerify{|PAIR|} fx fy p vst = fy (fmap fromPAIRY p) (fx (fmap fromPAIRX p) vst) gVerify{|PAIR|} fx fy p vst = fy (fmap fromPAIRY p) (fx (fmap fromPAIRX p) vst)
gVerify{|CONS|} fx c vst = fx (fmap fromCONS c) vst gVerify{|CONS|} fx c vst = fx (fmap fromCONS c) vst
gVerify{|RECORD|} fx r vst=:{updateMask,verifyMask,optional}
# val = fmap fromRECORD r
# (cmu,um) = popMask updateMask
# vst = {vst & updateMask = childMasks cmu, verifyMask = []}
# (childMask,vst) = case isJust r of
True
# vst=:{verifyMask = childMask} = fx val {vst & optional = False}
= (childMask,{vst & verifyMask = childMask})
False
= ([],vst)
# (consMask,vst) = if (isTouched cmu) (VMValid Nothing childMask,vst) (VMUntouched Nothing optional childMask,vst)
= {vst & updateMask = um, optional = optional, verifyMask = appendToMask verifyMask consMask}
gVerify{|FIELD|} fx f vst = fx (fmap fromFIELD f) vst gVerify{|FIELD|} fx f vst = fx (fmap fromFIELD f) vst
gVerify{|EITHER|} _ _ Nothing vst = vst gVerify{|EITHER|} _ _ Nothing vst = vst
...@@ -33,29 +47,19 @@ gVerify{|OBJECT of d|} fx obj vst=:{updateMask,verifyMask,optional} ...@@ -33,29 +47,19 @@ gVerify{|OBJECT of d|} fx obj vst=:{updateMask,verifyMask,optional}
# val = fmap fromOBJECT obj # val = fmap fromOBJECT obj
# (cmu,um) = popMask updateMask # (cmu,um) = popMask updateMask
# vst = {vst & updateMask = childMasks cmu, verifyMask = []} # vst = {vst & updateMask = childMasks cmu, verifyMask = []}
# (consMask,vst) = case (isRecordType d,d.gtd_num_conses) of # (consMask,vst) = case d.gtd_num_conses of
(False,1) // ADT's with just one constructor 1 // ADT's with just one constructor
# vst=:{verifyMask = childMask} = fx val vst # vst=:{verifyMask = childMask} = fx val vst
# vst = {vst & verifyMask = childMask} # vst = {vst & verifyMask = childMask}
| isTouched cmu = (VMValid Nothing childMask,vst) | isTouched cmu = (VMValid Nothing childMask,vst)
| otherwise = (VMUntouched Nothing optional childMask,vst) | otherwise = (VMUntouched Nothing optional childMask,vst)
(False,_) // ADT's with multiple constructors _ // ADT's with multiple constructors
# vst=:{verifyMask = childMask} = fx val {vst & optional = False} # vst=:{verifyMask = childMask} = fx val {vst & optional = False}
# vst = {vst & verifyMask = childMask} # vst = {vst & verifyMask = childMask}
= case cmu of = case cmu of
Blanked | not optional = (VMInvalid IsBlankError childMask,vst) Blanked | not optional = (VMInvalid IsBlankError childMask,vst)
Untouched = (VMUntouched (Just "Select an option") optional childMask,vst) Untouched = (VMUntouched (Just "Select an option") optional childMask,vst)
_ = (VMValid (Just "Select an option") childMask,vst) _ = (VMValid (Just "Select an option") childMask,vst)
(True,_) // Records
//Only compute child verify mask if record has value. Else you can end up in endless recursion!
# (childMask,vst) = case isJust obj of
True
# vst=:{verifyMask = childMask} = fx val {vst & optional = False}
= (childMask,{vst & verifyMask = childMask})
False
= ([],vst)
| isTouched cmu = (VMValid Nothing childMask,vst)
| otherwise = (VMUntouched Nothing optional childMask,vst)
= {vst & updateMask = um, optional = optional, verifyMask = appendToMask verifyMask consMask} = {vst & updateMask = um, optional = optional, verifyMask = appendToMask verifyMask consMask}
gVerify{|[]|} fx mbL vst=:{optional,verifyMask,updateMask,staticDisplay} gVerify{|[]|} fx mbL vst=:{optional,verifyMask,updateMask,staticDisplay}
......
definition module GenVisualize definition module GenVisualize
import HTML, JSON, TUIDefinition import HTML, JSON_NG, TUIDefinition
import StdGeneric, Maybe, Void, Either import StdGeneric, Maybe, Void, Either
import GenUpdate, GenVerify import GenUpdate, GenVerify
from Map import :: Map from Map import :: Map
...@@ -11,7 +11,7 @@ from Map import :: Map ...@@ -11,7 +11,7 @@ from Map import :: Map
generic gVisualizeText a :: !StaticVisualizationMode !a -> [String] generic gVisualizeText a :: !StaticVisualizationMode !a -> [String]
//Default available instances //Default available instances
derive gVisualizeText UNIT, PAIR, EITHER, CONS, OBJECT, FIELD derive gVisualizeText UNIT, PAIR, EITHER, CONS, OBJECT, RECORD, FIELD
derive gVisualizeText Int, Real, Char, Bool, String derive gVisualizeText Int, Real, Char, Bool, String
derive gVisualizeText Dynamic, [], Maybe, Either, (,), (,,), (,,,), (->), JSONNode, Void, HtmlTag, Display, Editable, Hidden, VisualizationHint, Timestamp derive gVisualizeText Dynamic, [], Maybe, Either, (,), (,,), (,,,), (->), JSONNode, Void, HtmlTag, Display, Editable, Hidden, VisualizationHint, Timestamp
derive gVisualizeText Note, Username, Password, Date, Time, DateTime, Document, FormButton, EUR, USD, User, UserConstraint, RadioChoice, ComboChoice, GridChoice, DynamicChoice, CheckMultiChoice, Map, TreeChoice, Tree, TreeNode, Table derive gVisualizeText Note, Username, Password, Date, Time, DateTime, Document, FormButton, EUR, USD, User, UserConstraint, RadioChoice, ComboChoice, GridChoice, DynamicChoice, CheckMultiChoice, Map, TreeChoice, Tree, TreeNode, Table
...@@ -29,7 +29,7 @@ derive gVisualizeText EmailAddress, Action, HtmlInclude, ManagementMeta, TaskPri ...@@ -29,7 +29,7 @@ derive gVisualizeText EmailAddress, Action, HtmlInclude, ManagementMeta, TaskPri
generic gVisualizeEditor a | gVisualizeText a, gHeaders a, gGridRows a :: !(Maybe a) !*VSt -> (!VisualizationResult,!*VSt) generic gVisualizeEditor a | gVisualizeText a, gHeaders a, gGridRows a :: !(Maybe a) !*VSt -> (!VisualizationResult,!*VSt)
//Default available instances //Default available instances
derive gVisualizeEditor UNIT, PAIR, EITHER, CONS, OBJECT, FIELD derive gVisualizeEditor UNIT, PAIR, EITHER, CONS, OBJECT, RECORD, FIELD
derive gVisualizeEditor Int, Real, Char, Bool, String derive gVisualizeEditor Int, Real, Char, Bool, String
derive gVisualizeEditor Dynamic, [], Maybe, Either, (,), (,,), (,,,), (->), JSONNode, Void, HtmlTag, Display, Editable, Hidden, VisualizationHint, Timestamp derive gVisualizeEditor Dynamic, [], Maybe, Either, (,), (,,), (,,,), (->), JSONNode, Void, HtmlTag, Display, Editable, Hidden, VisualizationHint, Timestamp
derive gVisualizeEditor Note, Username, Password, Date, Time, DateTime, Document, FormButton, EUR, USD, User, UserConstraint, RadioChoice, ComboChoice, GridChoice, DynamicChoice, CheckMultiChoice, Map, TreeChoice, Tree, TreeNode, Table derive gVisualizeEditor Note, Username, Password, Date, Time, DateTime, Document, FormButton, EUR, USD, User, UserConstraint, RadioChoice, ComboChoice, GridChoice, DynamicChoice, CheckMultiChoice, Map, TreeChoice, Tree, TreeNode, Table
...@@ -40,7 +40,7 @@ derive gVisualizeEditor EmailAddress, Action, HtmlInclude, ManagementMeta, TaskP ...@@ -40,7 +40,7 @@ derive gVisualizeEditor EmailAddress, Action, HtmlInclude, ManagementMeta, TaskP
generic gHeaders a :: (a, ![String]) generic gHeaders a :: (a, ![String])
//Default available instances //Default available instances
derive gHeaders UNIT, PAIR, EITHER, CONS, OBJECT, FIELD derive gHeaders UNIT, PAIR, EITHER, CONS, OBJECT, RECORD, FIELD
derive gHeaders Int, Real, Char, Bool, String derive gHeaders Int, Real, Char, Bool, String
derive gHeaders Dynamic, [], Maybe, Either, (,), (,,), (,,,), (->), JSONNode, Void, HtmlTag, Display, Editable, Hidden, VisualizationHint, Timestamp derive gHeaders Dynamic, [], Maybe, Either, (,), (,,), (,,,), (->), JSONNode, Void, HtmlTag, Display, Editable, Hidden, VisualizationHint, Timestamp
derive gHeaders Note, Username, Password, Date, Time, DateTime, Document, FormButton, EUR, USD, User, UserConstraint, RadioChoice, ComboChoice, GridChoice, DynamicChoice, CheckMultiChoice, Map, TreeChoice, Tree, TreeNode, Table derive gHeaders Note, Username, Password, Date, Time, DateTime, Document, FormButton, EUR, USD, User, UserConstraint, RadioChoice, ComboChoice, GridChoice, DynamicChoice, CheckMultiChoice, Map, TreeChoice, Tree, TreeNode, Table
...@@ -50,7 +50,7 @@ derive gHeaders EmailAddress, Action, HtmlInclude, ManagementMeta, TaskPriority, ...@@ -50,7 +50,7 @@ derive gHeaders EmailAddress, Action, HtmlInclude, ManagementMeta, TaskPriority,
generic gGridRows a | gVisualizeText a :: !a ![String] -> Maybe [String] generic gGridRows a | gVisualizeText a :: !a ![String] -> Maybe [String]
//Default available instances //Default available instances
derive gGridRows UNIT, PAIR, EITHER, CONS, OBJECT, FIELD derive gGridRows UNIT, PAIR, EITHER, CONS, OBJECT, RECORD, FIELD
derive gGridRows Int, Real, Char, Bool, String derive gGridRows Int, Real, Char, Bool, String
derive gGridRows Dynamic, [], Maybe, Either, (,), (,,), (,,,), (->), JSONNode, Void, HtmlTag, Display, Editable, Hidden, VisualizationHint, Timestamp derive gGridRows Dynamic, [], Maybe, Either, (,), (,,), (,,,), (->), JSONNode, Void, HtmlTag, Display, Editable, Hidden, VisualizationHint, Timestamp
derive gGridRows Note, Username, Password, Date, Time, DateTime, Document, FormButton, EUR, USD, User, UserConstraint, RadioChoice, ComboChoice, GridChoice, DynamicChoice, CheckMultiChoice, Map, TreeChoice, Tree, TreeNode, Table derive gGridRows Note, Username, Password, Date, Time, DateTime, Document, FormButton, EUR, USD, User, UserConstraint, RadioChoice, ComboChoice, GridChoice, DynamicChoice, CheckMultiChoice, Map, TreeChoice, Tree, TreeNode, Table
......
implementation module GenVisualize implementation module GenVisualize
import StdBool, StdChar, StdList, StdArray, StdTuple, StdMisc, StdGeneric, StdEnum, StdFunc, List, Generic import StdBool, StdChar, StdList, StdArray, StdTuple, StdMisc, StdGeneric, StdEnum, StdFunc, List_NG, Generic_NG
import GenUpdate, GenVerify, Util, Maybe, Functor, Text, HTML, JSON, TUIDefinition, SystemTypes, HtmlUtil, LayoutCombinators import GenUpdate, GenVerify, Util, Maybe, Functor, Text, HTML, JSON_NG, TUIDefinition, SystemTypes, HtmlUtil, LayoutCombinators
visualizeAsEditor :: !a !VerifyMask !TaskId !(Maybe (!String,!JSONNode)) !*IWorld -> (!Maybe TUIDef,!*IWorld) | gVisualizeEditor{|*|} a visualizeAsEditor :: !a !VerifyMask !TaskId !(Maybe (!String,!JSONNode)) !*IWorld -> (!Maybe TUIDef,!*IWorld) | gVisualizeEditor{|*|} a
visualizeAsEditor v vmask taskId editEvent iworld visualizeAsEditor v vmask taskId editEvent iworld
...@@ -20,6 +20,12 @@ generic gVisualizeText a :: !StaticVisualizationMode !a -> [String] ...@@ -20,6 +20,12 @@ generic gVisualizeText a :: !StaticVisualizationMode !a -> [String]
gVisualizeText{|UNIT|} _ _ = [] gVisualizeText{|UNIT|} _ _ = []
gVisualizeText{|RECORD|} fx mode (RECORD x)
# viz = fx mode x
= case mode of
AsLabel = take 1 viz
AsDisplay = viz
gVisualizeText{|FIELD of d|} fx mode (FIELD x) gVisualizeText{|FIELD of d|} fx mode (FIELD x)
# viz = fx mode x # viz = fx mode x
= case mode of = case mode of
...@@ -29,15 +35,7 @@ gVisualizeText{|FIELD of d|} fx mode (FIELD x) ...@@ -29,15 +35,7 @@ gVisualizeText{|FIELD of d|} fx mode (FIELD x)
gVisualizeText{|OBJECT|} fx mode (OBJECT x) = fx mode x gVisualizeText{|OBJECT|} fx mode (OBJECT x) = fx mode x
gVisualizeText{|CONS of d|} fx mode (CONS x) gVisualizeText{|CONS of d|} fx mode (CONS x)
# viz = fx mode x = normalADTStaticViz (fx mode x)
= case mode of
AsLabel
//For records only show the first field
| isRecordCons d = take 1 viz
| otherwise = normalADTStaticViz viz
AsDisplay
| isRecordCons d = viz
| otherwise = normalADTStaticViz viz