implementation module iTasks.API.Extensions.CodeMirror import StdMisc, StdString, StdArray, StdDebug import Data.Maybe, Data.List, Text import iTasks.API.Core.Client.Editlet import iTasks.API.Core.Client.Tasklet import iTasks.API.Core.Client.Interface derive class iTask CodeMirrorConfiguration, CodeMirrorDiff, CodeMirror, CodeMirrorClient, CodeMirrorClientSt, JSCM /* derive JSONEncode CodeMirrorConfiguration, CodeMirrorDiff, CodeMirror derive JSONDecode CodeMirrorConfiguration, CodeMirrorDiff, CodeMirror derive gDefault CodeMirrorConfiguration, CodeMirrorDiff, CodeMirror derive gEq CodeMirrorConfiguration, CodeMirrorDiff, CodeMirror derive gText CodeMirrorConfiguration, CodeMirrorDiff, CodeMirror derive gEditor CodeMirrorConfiguration, CodeMirrorDiff, CodeMirror derive gEditMeta CodeMirrorConfiguration, CodeMirrorDiff, CodeMirror derive gUpdate CodeMirrorConfiguration, CodeMirrorDiff, CodeMirror derive gVerify CodeMirrorConfiguration, CodeMirrorDiff, CodeMirror */ :: JSCM = JSCM toAttrValue (CMMode a) = ("mode", toJSVal a) toAttrValue (CMTheme a) = ("theme", toJSVal a) toAttrValue (CMIdenUnit a) = ("idenUnit", toJSVal a) toAttrValue (CMSmartIdent a) = ("smartIdent", toJSVal a) toAttrValue (CMTabSize a) = ("tabSize", toJSVal a) toAttrValue (CMIndentWithTabs a) = ("indentWithTabs", toJSVal a) toAttrValue (CMElectricChars a) = ("electricChars", toJSVal a) toAttrValue (CMRtlMoveVisually a) = ("rtlMoveVisually", toJSVal a) toAttrValue (CMKeyMap a) = ("keyMap", toJSVal a) toAttrValue (CMLineWrapping a) = ("lineWrapping", toJSVal a) toAttrValue (CMLineNumbers a) = ("lineNumbers", toJSVal a) toAttrValue (CMFirstLineNumber a) = ("firstLineNumber", toJSVal a) toAttrValue (CMReadOnly a) = ("readOnly", toJSVal a) toAttrValue (CMShowCursorWhenSelecting a) = ("showCursorWhenSelecting", toJSVal a) toAttrValue (CMUndoDepth a) = ("undoDepth", toJSVal a) toAttrValue (CMHistoryEventDelay a) = ("historyEventDelay", toJSVal a) toAttrValue (CMTabindex a) = ("tabindex", toJSVal a) toAttrValue (CMAutofocus a) = ("autofocus", toJSVal a) toAttrValue (CMDragDrop a) = ("dragDrop", toJSVal a) toAttrValue (CMCursorBlinkRate a) = ("cursorBlinkRate", toJSVal a) toAttrValue (CMCursorScrollMargin a) = ("cursorScrollMargin", toJSVal a) toAttrValue (CMCursorHeight a) = ("cursorHeight", toJSVal a) toAttrValue (CMWorkTime a) = ("workTime", toJSVal a) toAttrValue (CMWorkDelay a) = ("workDelay", toJSVal a) toAttrValue (CMPollInterval a) = ("pollInterval", toJSVal a) toAttrValue (CMFlattenSpans a) = ("flattenSpans", toJSVal a) toAttrValue (CMMaxHighlightLength a) = ("maxHighlightLength", toJSVal a) toAttrValue (CMCrudeMeasuringFrom a) = ("crudeMeasuringFrom", toJSVal a) toAttrValue (CMViewportMargin a) = ("viewportMargin", toJSVal a) toAttrValue (CMStyleActiveLine a) = ("styleActiveLine", toJSVal a) shallowEq a b = fst (toAttrValue a) == fst (toAttrValue b) createConfigurationObject :: [CodeMirrorConfiguration] !*JSWorld -> *(!JSObj CodeMirrorConfiguration, !*JSWorld) createConfigurationObject cs world # (obj, world) = jsEmptyObject world = (obj, foldl (set obj) world (map toAttrValue cs)) where set obj world (attr,value) = jsSetObjectAttr attr value obj world setOptions :: [CodeMirrorConfiguration] (JSObj JSCM) !*JSWorld -> *JSWorld setOptions cs cm world # world = foldl upd world (map toAttrValue cs) = loadModulesIfNeeded cs cm world where upd world (attr, val) = snd (callObjectMethod "setOption" [toJSArg attr, toJSArg val] cm world) loadModulesIfNeeded :: [CodeMirrorConfiguration] (JSObj JSCM) !*JSWorld -> *JSWorld loadModulesIfNeeded cs cm world # (cmobj, world) = findObject "CodeMirror" world // Load mode # world = case find isSetMode cs of Nothing = world (Just (CMMode mode)) = snd (callObjectMethod "autoLoadMode" [toJSArg cm, toJSArg mode] cmobj world) // Load theme = case find isSetTheme cs of Nothing = world (Just (CMTheme theme)) = addCSSFromUrl ("theme/"+++theme+++".css") world where isSetMode (CMMode _) = True isSetMode _ = False isSetTheme (CMTheme _) = True isSetTheme _ = False applyDiffs :: !ComponentId ![CodeMirrorDiff] !CodeMirrorClient !*JSWorld -> *(!CodeMirrorClient, !*JSWorld) applyDiffs cid diffs clval=:{initQueue,mbSt=Nothing} world // Save updates until initialization is finished = ({clval & initQueue = initQueue ++ diffs}, world) applyDiffs cid [] clval=:{mbSt=Just st=:{codeMirror,marks}} world // Nothing to do = (clval, world) applyDiffs cid diffs clval=:{mbSt=Just st=:{codeMirror,marks}} world // disable system event handlers # world = manageSystemEvents "off" st world # world = setOptions opts codeMirror world # world = loadModulesIfNeeded opts codeMirror world # (cmdoc, world) = callObjectMethod "getDoc" [] codeMirror world # world = case find isSetPos nopts of Nothing = world (Just (SetPosition idx)) # (pos, world) = tupleToPos idx world = snd (callObjectMethod "setCursor" [toJSArg pos] cmdoc world) # world = case find isSetSel nopts of Nothing = world (Just (SetSelection Nothing)) // Clear the selection # (pos, world) = callObjectMethod "getCursor" [] cmdoc world = snd (callObjectMethod "setSelection" [toJSArg pos, toJSArg pos] cmdoc world) (Just (SetSelection (Just (idx1,idx2)))) # (pos1, world) = tupleToPos idx1 world # (pos2, world) = tupleToPos idx2 world = snd (callObjectMethod "setSelection" [toJSArg pos1, toJSArg pos2] cmdoc world) # world = case find isReplaceRange nopts of Nothing = world (Just (ReplaceRange (flines,llines) diff)) = applyDiffClient cmdoc flines llines diff world # (marks, world) = case find isSetHighlights nopts of Nothing = (marks, world) (Just (SetHighlights newmarks)) // Clear all marks //# (marks, world) = (cmdoc .# "getAllMarks" .$ ()) world //# (marks, world) = fromJSArray marks id world # world = foldl (\world m -> snd ((m .# "clear" .$ ()) world)) world marks // Set marks = foldl (\(ms, world) pos -> let (m,w) = addMark cmdoc pos world in ([m:ms], w)) ([], world) newmarks // enable system event handlers # world = manageSystemEvents "on" st world = ({clval & mbSt = Just {st & marks = marks}}, world) where (opts`, nopts) = splitWith isSetOpt diffs opts = map (\(SetOption opt) -> opt) opts` isSetPos (SetPosition _) = True isSetPos _ = False isSetSel (SetSelection _) = True isSetSel _ = False isSetOpt (SetOption _) = True isSetOpt _ = False isReplaceRange (ReplaceRange _ _) = True isReplaceRange _ = False isSetHighlights (SetHighlights _) = True isSetHighlights _ = False initializeClient :: !((EditletEventHandlerFunc [CodeMirrorDiff] CodeMirrorClient) ComponentId -> JSFun ()) ![(String, EditletEventHandlerFunc [CodeMirrorDiff] CodeMirrorClient)] ComponentId {JSObj JSEvent} !CodeMirrorClient !*JSWorld -> *(!CodeMirrorClient, !ComponentDiff [CodeMirrorDiff] CodeMirrorClient, !*JSWorld) initializeClient mkHandler eventHandlers cid _ clval=:{val={source,configuration},initQueue} world # (ta, world) = .? (getElementById (sourcearea cid)) world # (co, world) = createConfigurationObject configuration world # (cmobj, world) = findObject "CodeMirror" world # (this, world) = jsThis world # (cm, world) = jsApply cmobj this [toJSArg ta, toJSArg co] world # world = loadModulesIfNeeded configuration cm world # st = {codeMirror = cm, systemEventHandlers = systemEvents mkHandler, marks = []} # world = manageSystemEvents "on" st world # world = foldl (putOnEventHandler mkHandler cm) world eventHandlers # (editlets,world) = findObject "itwc.controller.editlets" world # (cmp,world) = .? (editlets .# cid) world # (clval,dff,world) = onAfterShow cm cid undef clval world # world = (cmp .# "afterResize" .= (toJSVal (mkHandler (onAfterShow cm) cid))) world # world = (cmp .# "afterShow" .= (toJSVal (mkHandler (onAfterShow cm) cid))) world // apply diffs queued during the initialization # (clval, world) = applyDiffs cid initQueue {clval & mbSt = Just st} world = (clval, NoDiff, world) where // Set the size directly because CodeMirror seems that cannot work with CSS3 FlexBox stuff onAfterShow cm cid _ st world # (editlets, world) = findObject "itwc.controller.editlets" world # (editlet,world) = jsGetObjectAttr cid editlets world # (domEl,world) = jsGetObjectAttr "domEl" editlet world # (style,world) = callObjectMethod "getComputedStyle" [toJSArg domEl] jsWindow world # (width,world) = jsGetObjectAttr "width" style world # (height,world) = jsGetObjectAttr "height" style world # (_,world) = (cm .# "setSize" .$ (width,height)) world = (st, NoDiff, world) putOnEventHandler mkHandler cm world (event, handler) = snd (callObjectMethod "on" [toJSArg event, toJSArg (mkHandler handler cid)] cm world) systemEvents mkHandler = [("cursorActivity", mkHandler onCursorActivity cid), ("change", mkHandler onChange cid)] isSetMode (CMMode _) = True isSetMode _ = False onChange cid {[0] = event} clval=:{val={source}, mbSt=Just {codeMirror}} world # (cmdoc, world) = callObjectMethod "getDoc" [] codeMirror world # (newsource, world) = callObjectMethod "getValue" [] cmdoc world # (nrlines, world) = callObjectMethod "lineCount" [] cmdoc world # nrlines = jsValToInt nrlines # (world, lines) = foldl (\(w,res) i -> let (line, w2) = readLine cmdoc i w in (w2, [line: res])) (world, []) (reverse [0..nrlines-1]) # clDiff = mkDiff (genDiffServer clval.val {clval.val & source = lines}) = ({clval & val={clval.val & source = lines}}, clDiff, world) where readLine cmdoc n world # (line, world) = callObjectMethod "getLine" [toJSArg n] cmdoc world = (jsValToString line, world) onCursorActivity cid event clval=:{val, mbSt=Just {codeMirror}} world # (cmdoc, world) = callObjectMethod "getDoc" [] codeMirror world # (pos, world) = callObjectMethod "getCursor" [toJSArg "start"] cmdoc world # (idx1, world) = posToTuple pos world # val = {val & position = idx1} # (pos, world) = callObjectMethod "getCursor" [toJSArg "end"] cmdoc world # (idx2, world) = posToTuple pos world # val = if (idx1 == idx2) {val & selection = Nothing} {val & selection = Just (idx1,idx2)} # clDiff = mkDiff (genDiffServer clval.val val) = ({clval & val = val}, clDiff, world) mkDiff :: !(Maybe [CodeMirrorDiff]) -> ComponentDiff [CodeMirrorDiff] CodeMirrorClient mkDiff (Just ds) = Diff ds (\_ st world -> (st, NoDiff, world)) mkDiff _ = NoDiff manageSystemEvents direction {codeMirror, systemEventHandlers} world = foldl sw world systemEventHandlers where sw world (event, handler) = snd (callObjectMethod direction [toJSArg event, toJSArg handler] codeMirror world) posToTuple cmpos world # (line, world) = .? (cmpos .# "line") world # (ch, world) = .? (cmpos .# "ch") world = ((jsValToInt line, jsValToInt ch), world) tupleToPos (line, ch) world # (cmpos, world) = jsEmptyObject world # world = jsSetObjectAttr "line" (toJSVal line) cmpos world # world = jsSetObjectAttr "ch" (toJSVal ch) cmpos world = (cmpos, world) addMark cmdoc (i1,i2) world # (p1, world) = tupleToPos i1 world # (p2, world) = tupleToPos i2 world # (conf, world) = jsEmptyObject world # world = (conf .# "className" .= "cm-highlight") world = (cmdoc .# "markText" .$ (p1,p2,conf)) world sourcearea :: String -> String sourcearea id = "cm_source_" +++ id codeMirrorEditlet :: !CodeMirror ![(String, EditletEventHandlerFunc [CodeMirrorDiff] CodeMirrorClient)] -> Editlet CodeMirror [CodeMirrorDiff] CodeMirrorClient codeMirrorEditlet g eventHandlers = { Editlet | currVal = g , defValSrv = {source = [], configuration = [], position = (0,0), selection = Nothing, highlighted = []} , genUI = \cid world -> (editletUIDef cid, world) , initClient = onInit , appDiffClt = appDiffClient , genDiffSrv = genDiffServer , appDiffSrv = appDiffServer } where editletUIDef :: a -> ComponentHTML | toString a editletUIDef cid = { ComponentHTML | html = DivTag [] [StyleTag [] [Text "span.cm-highlight { background: #F3FA25 } \n .CodeMirror-focused span.cm-highlight { background: #F3FA25; !important }"] //FAD328 ,DivTag [IdAttr (sourcearea (toString cid)), StyleAttr "display: block; position: absolute;"] []] , width = ExactSize 600 , height = ExactSize 600 } onInit :: !((EditletEventHandlerFunc [CodeMirrorDiff] CodeMirrorClient) ComponentId -> JSFun ()) !ComponentId !*JSWorld -> (!CodeMirrorClient, !*JSWorld) onInit mkHandler cid world # clval = {val = {source = [], configuration = [], position = (0,0), selection = Nothing, highlighted = []}, initQueue = [], mbSt = Nothing} # (obj, world) = findObject "CodeMirror.defaults" world | not (jsIsUndefined obj) # (clval, _, world) = initializeClient mkHandler eventHandlers cid {} clval world = (clval, world) # world = addCSSFromUrl "codemirror.css" world # world = addJSFromUrl "codemirror.js" Nothing world # world = addJSFromUrl "addon/mode/loadmode.js" (Just (mkHandler (initializeClient mkHandler eventHandlers) cid)) world = (clval, world) appDiffClient :: !((EditletEventHandlerFunc [CodeMirrorDiff] CodeMirrorClient) ComponentId -> JSFun ()) !String ![CodeMirrorDiff] !CodeMirrorClient !*JSWorld -> *(!CodeMirrorClient, !*JSWorld) appDiffClient mkHandler cid diffs clval world = applyDiffs cid diffs {clval & val = appDiffServer diffs clval.val} world appDiffServer :: ![CodeMirrorDiff] !CodeMirror -> CodeMirror appDiffServer diffs val = foldl upd val diffs where upd val=:{configuration} (SetOption opt) = {val & configuration = replaceInList shallowEq opt configuration} upd val=:{position} (SetPosition pos) = {val & position = pos} upd val=:{selection} (SetSelection sel) = {val & selection = sel} upd val=:{source} (ReplaceRange (flines,llines) diff) = {val & source = applyDiffServer source flines llines diff} upd val=:{highlighted} (SetHighlights hs) = {val & highlighted = hs} genDiffServer :: !CodeMirror !CodeMirror -> Maybe [CodeMirrorDiff] genDiffServer val1 val2 = case ( map SetOption (differenceBy (===) val2.configuration val1.configuration) ++ if (val1.position == val2.position) [] [SetPosition val2.position] ++ if (val1.selection === val2.selection) [] [SetSelection val2.selection] ++ if ((not (isEmpty val1.highlighted) && isEmpty val2.highlighted) || (not (isEmpty val2.highlighted))) [SetHighlights val2.highlighted] [] ++ maybe [] (\(flines,llines,diff) -> [ReplaceRange (flines,llines) diff]) (genDiffRange val1.source val2.source) ) of [] = Nothing diffs = Just diffs applyDiffClient :: !(JSVal (JSObject a)) !Int !Int ![String] *JSWorld -> *JSWorld applyDiffClient cmdoc flines llines diff world # (nrlines, world) = callObjectMethod "lineCount" [] cmdoc world # nrlines = jsValToInt nrlines # (line1, world) = callObjectMethod "getLine" [toJSArg (flines - 1)] cmdoc world # line1 = if (jsIsUndefined line1) "" (jsValToString line1) | (size line1 == 0 && nrlines == 1) || (nrlines == flines + llines) = insert line1 world = replace nrlines world where replace :: !Int !*JSWorld -> *JSWorld replace nrlines world # world = jsTrace (flines) world # world = jsTrace (nrlines - llines - 1) world # world = jsTrace ("\"" +++ join "\n" diff +++ "\n\"") world # (cmposfrom, world) = tupleToPos (flines, 0) world # (cmposto, world) = tupleToPos (nrlines - llines - 1, 0) world = snd (callObjectMethod "replaceRange" [toJSArg (join "\n" diff +++ "\n"), toJSArg cmposfrom, toJSArg cmposto] cmdoc world) insert :: !String !*JSWorld -> *JSWorld insert line1 world # (cmpos, world) = tupleToPos (flines - 1, size line1) world = foldl (\w l -> snd (callObjectMethod "replaceRange" [toJSArg (l +++ "\n"), toJSArg cmpos, toJSArg cmpos] cmdoc w)) world (reverse diff) applyDiffServer :: ![String] !Int !Int ![String] -> [String] applyDiffServer os flines llines diff = take flines os ++ diff ++ drop (length os - llines) os genDiffRange :: ![String] ![String] -> Maybe (!Int, !Int, ![String]) genDiffRange os ns = fmap addlines (calcDiffRange os ns) where lns = length ns addlines :: !(!Int, !Int) -> (!Int, !Int, ![String]) addlines (flines, llines) = (flines, llines, take (lns-llines-flines) (drop flines ns)) // (valid lines from the left, valid lines from the right) calcDiffRange :: ![String] ![String] -> Maybe (!Int, !Int) calcDiffRange [] [] = Nothing calcDiffRange [] _ = Just (0,0) calcDiffRange os ns | flines == los = Nothing = Just (flines, llines) where flines = firstdiff os ns 0 llines = firstdiff (reverse os) (reverse ns) 0 los = length os firstdiff [] _ l = l firstdiff [o:os] [] l = l firstdiff [o:os] [n:ns] l | o == n = firstdiff os ns (l+1) = l firstDiff :: !String !String -> Int firstDiff str1 str2 = if (size str1 == size str2 && diff == size str1) -1 diff where diff = d 0 d p | (p >= size str1) || (p >= size str2) = p d p | str1.[p] == str2.[p] = d (p+1) d p = p lastDiff :: !String !String -> Int lastDiff str1 str2 = if (size str1 == size str2 && diff == size str1) -1 diff where s1 = size str1 s2 = size str2 diff = d 0 d p | (s1 - p - 1 < 0) || (s1 - p - 1 < 0) = p d p | str1.[p] == str2.[p] = d (p+1) d p = p