GenRecord.icl 4.56 KB
Newer Older
1 2
implementation module GenRecord

3
import StdTuple, StdList, StdFunc, Error, Util, GenUpdate, Map, Generic_NG, Tuple
4
from dynamic_string import copy_to_string, copy_from_string
5 6 7 8 9 10

copyRecord :: !a !b -> b | GenRecord a & GenRecord b
copyRecord src dst
	# srcFields = gGetRecordFields{|*|} src [] newMap
	= fst (gPutRecordFields{|*|} dst [] srcFields)
	
11
mapRecord :: !a -> b | GenRecord a & GenRecord, gUpdate{|*|} b
12 13
mapRecord rec
	# fields = gGetRecordFields{|*|} rec [] newMap
14
	= fst (gPutRecordFields{|*|} defaultValue [] fields)
15 16 17
	
generic gGetRecordFields r :: !r ![GenType] !*RecordFields -> *RecordFields

18
gGetRecordFields{|OBJECT of d|} fx (OBJECT o) _ fields = fields
19 20 21 22 23 24 25
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
	RIGHT y	= fy y types fields
gGetRecordFields{|PAIR|} fx fy (PAIR x y) types fields
	# fields = fx x types fields
	= fy y types fields
26
gGetRecordFields{|RECORD of d|} fx (RECORD r) _ fields = fx r (getFieldTypes d) fields
27
gGetRecordFields{|FIELD of d|} _ f types fields = put d.gfd_name (GenericDyn (copy_to_string f) (types !! d.gfd_index)) fields
28 29 30 31 32 33 34 35 36 37
gGetRecordFields{|UNIT|} _ _ fields = fields
gGetRecordFields{|Int|}		_ _ fields = fields
gGetRecordFields{|Real|}	_ _ fields = fields
gGetRecordFields{|Char|}	_ _ fields = fields
gGetRecordFields{|Bool|}	_ _ fields = fields
gGetRecordFields{|String|}	_ _ fields = fields
gGetRecordFields{|(->)|} _ _ _ _ fields = fields
gGetRecordFields{|Dynamic|} _ _ fields = fields

derive gGetRecordFields [], Maybe, Either, (,), (,,), (,,,), Void, Display, Editable, Hidden, VisualizationHint, Timestamp
38
derive gGetRecordFields Note, Username, Password, Date, Time, DateTime, Document, FormButton, EUR, USD, User, RadioChoice, CheckMultiChoice, Map, TreeChoice, Tree, TreeNode, HtmlTag, HtmlAttr
39
derive gGetRecordFields EmailAddress, Action, ButtonState
40 41 42

generic gPutRecordFields r :: !r ![GenType] !*RecordFields -> (!r,!*RecordFields)

43
gPutRecordFields{|OBJECT of d|} fx obj=:(OBJECT o) _ fields = (obj,fields)
44 45 46 47 48 49 50 51
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)
	RIGHT y	= appFst RIGHT (fy y types fields)
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)
52 53
gPutRecordFields{|RECORD of d|} fx (RECORD r) _ fields
	= appFst RECORD (fx r (getFieldTypes d) fields)
54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71
gPutRecordFields{|FIELD of d|} _ f types fields
	# (mbGenDyn,fields) = delU d.gfd_name fields
	# f` = case mbGenDyn of
		Just genDyn = case matchGenericDyn genDyn (types !! d.gfd_index) of
			Just f	= f
			Nothing	= f
		Nothing		= f
	= (f`,fields)
gPutRecordFields{|UNIT|} _ _ fields = (UNIT,fields)
gPutRecordFields{|Int|}		c _ fields = (c,fields)
gPutRecordFields{|Real|}	c _ fields = (c,fields)
gPutRecordFields{|Char|}	c _ fields = (c,fields)
gPutRecordFields{|Bool|}	c _ fields = (c,fields)
gPutRecordFields{|String|}	c _ fields = (c,fields)
gPutRecordFields{|(->)|} _ _ f _ fields = (f,fields)
gPutRecordFields{|Dynamic|} dyn _ fields = (dyn,fields)

derive gPutRecordFields [], Maybe, Either, (,), (,,), (,,,), Void, Display, Editable, Hidden, VisualizationHint, Timestamp
72
derive gPutRecordFields Note, Username, Password, Date, Time, DateTime, Document, FormButton, EUR, USD, User, RadioChoice, CheckMultiChoice, Map, TreeChoice, Tree, TreeNode, HtmlTag, HtmlAttr
73
derive gPutRecordFields EmailAddress, Action, ButtonState
74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90

:: *RecordFields :== Map String GenericDyn
// This type is needed because dynamics can't be used inside generic functions.
// It includes the string representation of the value (generated by copy_to_string)
// and the generic type of it.
:: *GenericDyn = GenericDyn !*String !GenType

/**
* Tries to match & unpack a GenericDyn value.
*
* @param The GenericDyn
* @param The type to match
*
* @return The unpacked value if match succeeded.
*/
matchGenericDyn :: !*GenericDyn !GenType -> Maybe a
matchGenericDyn (GenericDyn str dynType) reqType
91
	| dynType === reqType	= Just (fst (copy_from_string str))
92 93 94
	| otherwise				= Nothing

// Retrieves the types of a record's fields.
95 96
getFieldTypes :: !GenericRecordDescriptor -> [GenType]
getFieldTypes {grd_type} = getFieldTypes` grd_type []
97 98 99 100 101
where
	getFieldTypes` (GenTypeArrow field next) acc	= getFieldTypes` next [field:acc]
	getFieldTypes` _ acc							= reverse acc
getFieldTypes _ = []
	
102
derive gEq GenType