implementation module ExperimentalDomain import iTasks, Text derive gUpdate FormattedText, FormattedTextControls, SourceCode, SourceCodeLanguage, Color derive gMerge FormattedText, FormattedTextControls, SourceCode, SourceCodeLanguage, Color derive gVerify FormattedText, FormattedTextControls, SourceCode, SourceCodeLanguage, Color derive JSONEncode FormattedText, FormattedTextControls, SourceCode, SourceCodeLanguage, Color derive JSONDecode FormattedText, FormattedTextControls, SourceCode, SourceCodeLanguage, Color derive JSONEncode TUIFormattedText, TUIColorChooser, TUISourceCode derive bimap Maybe, (,) mkEmptyFormattedText :: !FormattedTextControls -> FormattedText mkEmptyFormattedText controls = mkFormattedText "" controls mkFormattedText :: !String !FormattedTextControls -> FormattedText mkFormattedText src controls = FormattedText src controls setFormattedTextSrc :: !String !FormattedText -> FormattedText setFormattedTextSrc cont (FormattedText _ controls) = FormattedText cont controls getFormattedTextSrc :: !FormattedText -> String getFormattedTextSrc (FormattedText src _) = removeMarkerTags src where removeMarkerTags s # s = case indexOf "" s + 14) (textSize s) s # s = case indexOf "" s + 12) (textSize s) s = s allControls :: FormattedTextControls allControls = { alignmentControls = True , colorControls = True , fontControl = True , fontSizeControls = True , formatControls = True , linkControl = True , listControls = True , sourceEditControl = True } noControls :: FormattedTextControls noControls = { alignmentControls = False , colorControls = False , fontControl = False , fontSizeControls = False , formatControls = False , linkControl = False , listControls = False , sourceEditControl = False } :: TUIFormattedText = { xtype :: !String , name :: !String , id :: !String , value :: !String , fieldLabel :: !Maybe String , optional :: !Bool , enableAlignments :: !Bool , enableColors :: !Bool , enableFont :: !Bool , enableFontSize :: !Bool , enableFormat :: !Bool , enableLinks :: !Bool , enableLists :: !Bool , enableSourceEdit :: !Bool } gVisualize{|FormattedText|} old new vst=:{vizType,label,idPrefix,currentPath,useLabels,optional,updateMask,verifyMask} #(cmu,um) = popMask updateMask #(cmv,vm) = popMask verifyMask #(err,hnt) = verifyElementStr cmu cmv # oldV = value2s (fst (popMask (childMasks cmu))) old # newV = value2s (fst (popMask (childMasks cmu))) new = case vizType of VEditorDefinition = ([TUIFragment (TUICustom (toJSON { TUIFormattedText | xtype = "itasks.tui.FormattedText" , name = dp2s contentPath , id = id , value = replaceMarkers oldV , fieldLabel = labelAttr useLabels label , optional = optional , enableAlignments = controls.alignmentControls , enableColors = controls.colorControls , enableFont = controls.fontControl , enableFontSize = controls.fontSizeControls , enableFormat = controls.formatControls , enableLinks = controls.linkControl , enableLists = controls.listControls , enableSourceEdit = controls.sourceEditControl } ))] , {VSt|vst & currentPath = stepDataPath currentPath, updateMask = um, verifyMask = vm}) VEditorUpdate | oldV <> newV = ([TUIUpdate (TUISetValue id (replaceMarkers newV))] , {VSt|vst & currentPath = stepDataPath currentPath, updateMask = um, verifyMask = vm}) _ # htmlFrag = case old of VBlank = Text "" VValue v = html v = ([HtmlFragment [htmlFrag]] , {VSt|vst & currentPath = stepDataPath currentPath}) 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 currentPath id = dp2id idPrefix contentPath controls = case old of VBlank = allControls VValue (FormattedText _ controls) = controls replaceMarkers v # v = replaceSubString SelectionStartMarker ("") v # v = replaceSubString SelectionEndMarker ("") v = v toUnformattedString :: !FormattedText !Bool -> String toUnformattedString (FormattedText s _) includeCursorMarkers # s = if includeCursorMarkers (insertMarkers s) s # s = replaceSubString "
" "\n" s # s = replaceSubString "
" "\n" s # s = replaceSubString "
" "\n" s # s = replaceSubString "
" "\n" s # s = replaceSubString "" "\n" s # s = stripHtmlTags s # s = replaceSubString " " " " s # s = replaceSubString "<" "<" s # s = replaceSubString ">" ">" s # s = replaceSubString "&" "&" s = s where stripHtmlTags s # fstOpen = indexOf "<" s # fstClose = indexOf ">" s | fstOpen <> -1 && fstClose <> -1 && fstOpen < fstClose = stripHtmlTags (subString 0 fstOpen s +++ subString (fstClose + 1) (textSize s - fstClose) s) | otherwise = s insertMarkers s # s = case indexOf "" s + 14) (textSize s) s # s = case indexOf "" s + 12) (textSize s) s = s removeMarkers :: !String -> String removeMarkers s # s = replaceSubString SelectionStartMarker "" s # s = replaceSubString SelectionEndMarker "" s = s instance html FormattedText where html (FormattedText src _) = RawText (removeMarkers src) instance toString FormattedText where toString (FormattedText s _) = s mkSourceCode :: !String !SourceCodeLanguage -> SourceCode mkSourceCode src lang = SourceCode src lang setSource :: !String !SourceCode -> SourceCode setSource src (SourceCode _ lang) = SourceCode src lang getSource :: !SourceCode -> String getSource (SourceCode src _) = src //'js', 'css', 'php', 'htm', 'html', 'xml' :: TUISourceCode = { xtype :: !String , name :: !String , id :: !String , value :: !String , fieldLabel :: !Maybe String , staticDisplay :: !Bool , optional :: !Bool , language :: !String } :: TUIColorChooser = { xtype :: !String , name :: !String , id :: !String , value :: !String , fieldLabel :: !Maybe String , staticDisplay :: !Bool , optional :: !Bool } gVisualize{|SourceCode|} old new vst=:{vizType,label,idPrefix,currentPath,useLabels,optional,renderAsStatic,updateMask,verifyMask} #(cmu,um) = popMask updateMask #(cmv,vm) = popMask verifyMask # oldV = value2s (fst (popMask (childMasks cmu))) old # newV = value2s (fst (popMask (childMasks cmu))) new #(err,hnt) = verifyElementStr cmu cmv = case vizType of VEditorDefinition = ([TUIFragment (TUICustom (toJSON { TUISourceCode | xtype = "itasks.tui.SourceCode" , name = dp2s contentPath , id = id , value = oldV , fieldLabel = labelAttr useLabels label , optional = optional , staticDisplay = renderAsStatic , language = language } ))] , {VSt|vst & currentPath = stepDataPath currentPath, updateMask = um, verifyMask = vm}) VEditorUpdate | oldV <> newV = ([TUIUpdate (TUISetValue id newV)] , {VSt|vst & currentPath = stepDataPath currentPath}) _ # htmlFrag = case old of VBlank = Text "" VValue v = html v = ([HtmlFragment [htmlFrag]] , {VSt|vst & currentPath = stepDataPath currentPath}) 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 currentPath id = dp2id idPrefix contentPath language = case old of VBlank = "" VValue (SourceCode _ lang) = case lang of JS = "js" CSS = "css" PHP = "php" HTML = "html" XML = "xml" Clean = "clean" instance html SourceCode where html (SourceCode src _) = Text src instance toString SourceCode where toString (SourceCode src _) = src gVisualize{|Color|} old new vst=:{vizType,label,idPrefix,currentPath,useLabels,optional, renderAsStatic,updateMask,verifyMask} #(cmu,um) = popMask updateMask #(cmv,vm) = popMask verifyMask # oldV = value2s (fst (popMask (childMasks cmu))) old # newV = value2s (fst (popMask (childMasks cmu))) new #(err,hnt) = verifyElementStr cmu cmv = case vizType of VEditorDefinition = ([TUIFragment (TUICustom (toJSON { TUIColorChooser | xtype = "itasks.tui.ColorChooser" , name = dp2s contentPath , id = id , value = oldV , fieldLabel = labelAttr useLabels label , optional = optional , staticDisplay = renderAsStatic } ))] , {VSt|vst & currentPath = stepDataPath currentPath, updateMask = um, verifyMask = vm}) VEditorUpdate | oldV <> newV = ([TUIUpdate (TUISetValue id newV)] , {VSt|vst & currentPath = stepDataPath currentPath, updateMask = um, verifyMask = vm}) _ # htmlFrag = case old of VBlank = Text "" VValue v = html v = ([HtmlFragment [htmlFrag]] , {VSt|vst & currentPath = stepDataPath currentPath}) 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 currentPath id = dp2id idPrefix contentPath instance html Color where html (Color c) = DivTag [StyleAttr ("background-color: #" +++ c +++ "; border: 1px solid; border-color: #ACA899; height: 10px; width: 10px;")] [] instance toString Color where toString (Color c) = "#" +++ c