Skip to content

GitLab

Commit 55e5eb7b authored by Bas Lijnse's avatar Bas Lijnse
Browse files
Options

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
Hide whitespace changes
Inline Side-by-side
Showing with 887 additions and 113 deletions
Compiler/CleanCompiler.exe
View file @ 55e5eb7b
This diff was suppressed by a .gitattributes entry.
Compiler/backend.dll
View file @ 55e5eb7b
No preview for this file type
Server/API/Common/CommonCombinators.icl
View file @ 55e5eb7b
......@@ -2,7 +2,7 @@ implementation module CommonCombinators
/**
* 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
from StdFunc import id, const, o
from SystemTypes import :: User(..), :: Note(..)
......
Server/API/Common/DBTasks.icl
View file @ 55e5eb7b
implementation module DBTasks
import StdList, StdOrdList, Util, List
import StdList, StdOrdList, Util, List_NG
import iTaskClass, Task, Shared
from CoreTasks import get, set, return
from CommonCombinators import >>|, >>=
......
Server/API/Common/InteractionTasks.icl
View file @ 55e5eb7b
......@@ -3,7 +3,7 @@ implementation module InteractionTasks
from StdFunc import id, const, o, flip
from SystemData import null
from Tuple import appSnd
from List import isMemberGen, instance Functor []
from List_NG import isMemberGen, instance Functor []
from Time import :: Timestamp(..)
import StdBool, StdList, StdMisc, StdTuple
......
Server/API/Core/CoreCombinators.icl
View file @ 55e5eb7b
implementation module CoreCombinators
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
from Map import qualified get, put, del
......
Server/API/Core/CoreTasks.icl
View file @ 55e5eb7b
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 iTaskClass, Task, TaskState, TaskEval, TaskStore, TUIDefinition, LayoutCombinators, Shared
from SharedDataSource import qualified read, write
......
Server/API/Core/IntegrationTasks.icl
View file @ 55e5eb7b
......@@ -2,7 +2,7 @@ implementation module IntegrationTasks
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 LayoutCombinators
......
Server/API/Core/SystemData.dcl
View file @ 55e5eb7b
......@@ -3,7 +3,7 @@ definition module SystemData
* This module provides access to the iTask framework data by means of
* 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 :: TaskListItem, :: Config, :: TaskId, :: TaskNo, :: InstanceNo, :: SharedTaskList
from Void import :: Void
......
Server/API/Core/SystemTypes.dcl
View file @ 55e5eb7b
......@@ -4,7 +4,7 @@ definition module SystemTypes
* 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 qualified get
from HTML import class html
......
Server/API/Core/SystemTypes.icl
View file @ 55e5eb7b
implementation module SystemTypes
from StdFunc import until
import StdInt, StdBool, StdClass, StdArray, StdTuple, StdMisc, StdList, StdFunc, StdOrdList, List, dynamic_string, Base64
import GenLexOrd, JSON, HTML, Text, Util
import StdInt, StdBool, StdClass, StdArray, StdTuple, StdMisc, StdList, StdFunc, StdOrdList, List_NG, dynamic_string, Base64
import JSON_NG, HTML, Text, Util
from Time import :: Timestamp(..)
from Task import :: TaskValue
......
Server/API/Extensions/GoogleMaps.icl
View file @ 55e5eb7b
implementation module GoogleMaps
import HTML, StdEnv, JSON, GenUpdate, GenVisualize, GenVerify
import HTML, StdEnv, JSON_NG, GenUpdate, GenVisualize, GenVerify
derive JSONEncode TUIGoogleMap, TUIGoogleMapOptions
derive JSONDecode MVCUpdate, ClickUpdate, ClickSource, ClickEvent, MarkerDragUpdate
......
Server/Framework/Engine.dcl
View file @ 55e5eb7b
......@@ -4,7 +4,7 @@ definition module Engine
* This is the primary function that creates the complete
* 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 HTTP import :: HTTPRequest, :: HTTPResponse
......
Server/Framework/GenRecord.dcl
View file @ 55e5eb7b
......@@ -34,13 +34,13 @@ generic gPutRecordFields r :: !r ![GenType] !*RecordFields -> (!r,!*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 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 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 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
......
Server/Framework/GenRecord.icl
View file @ 55e5eb7b
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
copyRecord :: !a !b -> b | GenRecord a & GenRecord b
......@@ -15,9 +15,7 @@ mapRecord rec
generic gGetRecordFields r :: !r ![GenType] !*RecordFields -> *RecordFields
gGetRecordFields{|OBJECT of d|} fx (OBJECT o) _ fields
| isRecordType d = fx o (getFieldTypes d) fields
| otherwise = fields
gGetRecordFields{|OBJECT of d|} fx (OBJECT o) _ fields = fields
gGetRecordFields{|CONS|} fx (CONS c) types fields = fx c types fields
gGetRecordFields{|EITHER|} fx fy either types fields = case either of
LEFT x = fx x types fields
......@@ -25,6 +23,7 @@ gGetRecordFields{|EITHER|} fx fy either types fields = case either of
gGetRecordFields{|PAIR|} fx fy (PAIR x y) types fields
# fields = fx x 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{|UNIT|} _ _ fields = fields
gGetRecordFields{|Int|} _ _ fields = fields
......@@ -41,9 +40,7 @@ derive gGetRecordFields EmailAddress, Action, ButtonState
generic gPutRecordFields r :: !r ![GenType] !*RecordFields -> (!r,!*RecordFields)
gPutRecordFields{|OBJECT of d|} fx obj=:(OBJECT o) _ fields
| isRecordType d = appFst OBJECT (fx o (getFieldTypes d) fields)
| otherwise = (obj,fields)
gPutRecordFields{|OBJECT of d|} fx obj=:(OBJECT o) _ fields = (obj,fields)
gPutRecordFields{|CONS|} fx (CONS c) types fields = appFst CONS (fx c types fields)
gPutRecordFields{|EITHER|} fx fy either types fields = case either of
LEFT x = appFst LEFT (fx x types fields)
......@@ -52,6 +49,8 @@ gPutRecordFields{|PAIR|} fx fy (PAIR x y) types fields
# (x`,fields) = fx x types fields
# (y`,fields) = fy y types 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
# (mbGenDyn,fields) = delU d.gfd_name fields
# f` = case mbGenDyn of
......@@ -93,8 +92,8 @@ matchGenericDyn (GenericDyn str dynType) reqType
| otherwise = Nothing
// Retrieves the types of a record's fields.
getFieldTypes :: !GenericTypeDefDescriptor -> [GenType]
getFieldTypes {gtd_conses=c=:[{gcd_type}]} = getFieldTypes` gcd_type []
getFieldTypes :: !GenericRecordDescriptor -> [GenType]
getFieldTypes {grd_type} = getFieldTypes` grd_type []
where
getFieldTypes` (GenTypeArrow field next) acc = getFieldTypes` next [field:acc]
getFieldTypes` _ acc = reverse acc
......
Server/Framework/GenUpdate.dcl
View file @ 55e5eb7b
......@@ -24,7 +24,7 @@ from Map import :: Map
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 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
......@@ -33,7 +33,7 @@ derive gUpdate ControlSize, FillControlSize, FillWControlSize, FillHControlSize
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 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
......
Server/Framework/GenUpdate.icl
View file @ 55e5eb7b
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
from StdFunc import id, const, o
from TUIDefinition import :: TUISize(..), :: TUIFixedSize, :: TUIWeight
......@@ -60,7 +60,20 @@ where
JSONInt consIdx | consIdx < length d.gtd_conses
= 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 (UDSearch (CONS c)) ust = appFst CONS (fx (UDSearch c) ust)
gUpdate{|FIELD|} fx UDCreate ust = appFst FIELD (fx UDCreate ust)
......@@ -284,6 +297,7 @@ generic gDefaultMask a :: !a -> [UpdateMask]
gDefaultMask{|UNIT|} _ = []
gDefaultMask{|OBJECT|} fx (OBJECT x) = [Touched (fx x)]
gDefaultMask{|CONS|} fx (CONS x) = fx x
gDefaultMask{|RECORD|} fx (RECORD x) = fx x
gDefaultMask{|FIELD|} fx (FIELD x) = fx x
gDefaultMask{|PAIR|} fx fy (PAIR x y) = fx x ++ fy y
gDefaultMask{|EITHER|} fx fy e = case e of
......
Server/Framework/GenVerify.dcl
View file @ 55e5eb7b
......@@ -22,7 +22,7 @@ generic gVerify a :: !(Maybe a) !*VerSt -> *VerSt
instance GenMask VerifyMask
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 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
......
Server/Framework/GenVerify.icl
View file @ 55e5eb7b
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
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
gVerify{|UNIT|} _ vst = 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{|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{|EITHER|} _ _ Nothing vst = vst
......@@ -33,29 +47,19 @@ gVerify{|OBJECT of d|} fx obj vst=:{updateMask,verifyMask,optional}
# val = fmap fromOBJECT obj
# (cmu,um) = popMask updateMask
# vst = {vst & updateMask = childMasks cmu, verifyMask = []}
# (consMask,vst) = case (isRecordType d,d.gtd_num_conses) of
(False,1) // ADT's with just one constructor
# (consMask,vst) = case d.gtd_num_conses of
1 // ADT's with just one constructor
# vst=:{verifyMask = childMask} = fx val vst
# vst = {vst & verifyMask = childMask}
| isTouched cmu = (VMValid Nothing 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 = {vst & verifyMask = childMask}
= case cmu of
Blanked | not optional = (VMInvalid IsBlankError childMask,vst)
Untouched = (VMUntouched (Just "Select an option") optional 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}
gVerify{|[]|} fx mbL vst=:{optional,verifyMask,updateMask,staticDisplay}
......
Server/Framework/GenVisualize.dcl
View file @ 55e5eb7b
definition module GenVisualize
import HTML, JSON, TUIDefinition
import HTML, JSON_NG, TUIDefinition
import StdGeneric, Maybe, Void, Either
import GenUpdate, GenVerify
from Map import :: Map
......@@ -11,7 +11,7 @@ from Map import :: Map
generic gVisualizeText a :: !StaticVisualizationMode !a -> [String]
//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 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
......@@ -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)
//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 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
......@@ -40,7 +40,7 @@ derive gVisualizeEditor EmailAddress, Action, HtmlInclude, ManagementMeta, TaskP
generic gHeaders a :: (a, ![String])
//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 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
......@@ -50,7 +50,7 @@ derive gHeaders EmailAddress, Action, HtmlInclude, ManagementMeta, TaskPriority,
generic gGridRows a | gVisualizeText a :: !a ![String] -> Maybe [String]
//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 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
......
Server/Framework/GenVisualize.icl
View file @ 55e5eb7b
implementation module GenVisualize
import StdBool, StdChar, StdList, StdArray, StdTuple, StdMisc, StdGeneric, StdEnum, StdFunc, List, Generic
import GenUpdate, GenVerify, Util, Maybe, Functor, Text, HTML, JSON, TUIDefinition, SystemTypes, HtmlUtil, LayoutCombinators
import StdBool, StdChar, StdList, StdArray, StdTuple, StdMisc, StdGeneric, StdEnum, StdFunc, List_NG, Generic_NG
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 v vmask taskId editEvent iworld
......@@ -20,6 +20,12 @@ generic gVisualizeText a :: !StaticVisualizationMode !a -> [String]
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)
# viz = fx mode x
= case mode of
......@@ -29,15 +35,7 @@ gVisualizeText{|FIELD of d|} fx mode (FIELD x)
gVisualizeText{|OBJECT|} fx mode (OBJECT x) = fx mode x
gVisualizeText{|CONS of d|} fx mode (CONS x)
# viz = 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
= normalADTStaticViz (fx mode x)
where
normalADTStaticViz viz
//If viz is empty, only show constructor name
......@@ -124,6 +122,31 @@ generic gVisualizeEditor a | gVisualizeText a, gHeaders a, gGridRows a :: !(Mayb
gVisualizeEditor{|UNIT|} _ vst
= (NormalEditor [],vst)
gVisualizeEditor{|RECORD|} fx _ _ _ val vst = visualizeCustom mkControl vst
where
mkControl name _ _ eventValue vst=:{taskId,editEvent,currentPath,optional,controlSize,renderAsStatic}
= case fmap fromRECORD val of
Nothing // Create checkbox to create record
| optional = (if renderAsStatic [] [checkbox False], vst)
# (viz,vst) = fx Nothing vst
= ([recordContainer (tuiOfEditor viz)],vst)
Just x
# (viz,vst) = fx (Just x) vst
= ([recordContainer (tuiOfEditor viz)],vst)
where
recordContainer viz = { content = TUIContainer (defaultContainer (if (optional && not renderAsStatic) [checkbox True] [] ++ viz))
, width = Just (FillParent 1 ContentSize)
, height = Just (WrapContent 0)
, margins = Nothing
}
checkbox c = sizedControl controlSize (TUIEditControl TUIBoolControl
{ name = name
, value = toJSON c
, taskId = fmap toString taskId
, eventValue = eventValue
})
gVisualizeEditor{|FIELD of d|} fx _ _ _ val vst=:{renderAsStatic}
# (vizBody,vst) = fx (fmap fromFIELD val) vst
= case vizBody of
......@@ -134,15 +157,13 @@ where
addLabel optional content
# label = {stringDisplay (camelCaseToWords d.gfd_name +++ if (optional || renderAsStatic) "" "*" +++ ":") & width = Just (Fixed 100)}
= [{content = TUIContainer {TUIContainer|defaultContainer [label: content] & direction = Horizontal}, width = Just (FillParent 1 ContentSize), height = Just (WrapContent 0), margins = Nothing}]
gVisualizeEditor{|OBJECT of d|} fx _ _ _ val vst=:{currentPath,selectedConsIndex = oldSelectedConsIndex,renderAsStatic,verifyMask,taskId,editEvent,controlSize}
//For objects we only peek at the verify mask, but don't take it out of the state yet.
//The masks are removed from the states when processing the CONS.
# (cmv,vm) = popMask verifyMask
# x = fmap fromOBJECT val
//Record: just strip of the OBJECT constructor and pass through, record container is created when processing the CONS
| isRecordType d
= fx x vst
//ADT with multiple constructors & not rendered static: Add the creation of a control for choosing the constructor
| d.gtd_num_conses > 1 && not renderAsStatic
# (items, vst=:{selectedConsIndex}) = fx x vst
......@@ -192,31 +213,9 @@ gVisualizeEditor{|CONS of d|} fx _ _ _ val vst = visualizeCustom mkControl vst
where
mkControl name _ _ eventValue vst=:{taskId,editEvent,currentPath,optional,controlSize,renderAsStatic}
# x = fmap fromCONS val
= case isRecordCons d of
False // normal ADT
# (viz,vst) = fx x vst
= (tuiOfEditor viz, {VSt | vst & selectedConsIndex = d.gcd_index})
True = case x of // record
Nothing // Create checkbox to create record
| optional = (if renderAsStatic [] [checkbox False], vst)
# (viz,vst) = fx Nothing vst
= ([recordContainer (tuiOfEditor viz)],vst)
Just x
# (viz,vst) = fx (Just x) vst
= ([recordContainer (tuiOfEditor viz)],vst)
where
recordContainer viz = { content = TUIContainer (defaultContainer (if (optional && not renderAsStatic) [checkbox True] [] ++ viz))
, width = Just (FillParent 1 ContentSize)
, height = Just (WrapContent 0)
, margins = Nothing
}
checkbox c = sizedControl controlSize (TUIEditControl TUIBoolControl
{ name = name
, value = toJSON c
, taskId = fmap toString taskId
, eventValue = eventValue
})
# (viz,vst) = fx x vst
= (tuiOfEditor viz, {VSt | vst & selectedConsIndex = d.gcd_index})
gVisualizeEditor{|PAIR|} fx _ _ _ fy _ _ _ val vst
# (x,y) = (fmap fromPAIRX val, fmap fromPAIRY val)
......@@ -455,8 +454,9 @@ derive gVisualizeEditor JSONNode, Either, (,), (,,), (,,,), Timestamp, Map, Emai
generic gHeaders a :: (a, ![String])
gHeaders{|OBJECT|} fx = (undef, snd fx)
gHeaders{|CONS of d|} fx = (undef, [camelCaseToWords gfd_name \\ {gfd_name} <- d.gcd_fields])
gHeaders{|OBJECT|} fx = (undef, [])
gHeaders{|RECORD of d|} fx = (undef, [camelCaseToWords fieldname \\ fieldname <- d.grd_fields])
gHeaders{|CONS|} fx = (undef, [])
gHeaders{|PAIR|} fx fy = (undef, [])
gHeaders{|FIELD|} fx = (undef, [])
gHeaders{|EITHER|} fx fy = (undef, [])
......@@ -476,11 +476,10 @@ derive gHeaders EmailAddress, Action, HtmlInclude, UserConstraint, ManagementMet
generic gGridRows a | gVisualizeText a :: !a ![String] -> Maybe [String]
gGridRows{|OBJECT of d|} fx _ (OBJECT o) acc
| isRecordType d = fmap reverse (fx o acc)
| otherwise = Nothing
gGridRows{|OBJECT|} _ _ _ _ = Nothing
gGridRows{|CONS|} fx _ (CONS c) acc = fx c acc
gGridRows{|PAIR|} fx _ fy _ (PAIR x y) acc = fy y (fromMaybe [] (fx x acc))
gGridRows{|RECORD|} fx _ (RECORD r) acc = fmap reverse (fx r acc)
gGridRows{|FIELD|} _ gx (FIELD f) acc = Just [concat (gx AsLabel f):acc]
gGridRows{|EITHER|} _ _ _ _ _ _ = abort "gGridRows: EITHER should not occur"
gGridRows{|Int|} i _ = Nothing
......
Server/Framework/HtmlUtil.dcl
View file @ 55e5eb7b
......@@ -3,7 +3,7 @@ definition module HtmlUtil
* This module provides rudimentary utilities for generating simple html pages.
*
*/
import HTML, JSON, HTTP
import HTML, JSON_NG, HTTP
/*
* Generate a 404 page
*/
......
Server/Framework/HtmlUtil.icl
View file @ 55e5eb7b
implementation module HtmlUtil
import HTML, JSON, Text, HTTP, Map, OS
import HTML, JSON_NG, Text, HTTP, Map, OS
import StdList, StdBool
embeddedStyle :: HtmlTag
......