implementation module iTasks.API.Extensions.CodeMirrorTasklet

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 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)

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

onInitClient hndCreator eventhandlers onLoadWrapper onLoadCont cid clval world
	# (obj, world) = findObject "CodeMirror.defaults" world
	| not (jsIsUndefined obj)
	    = onLoad hndCreator eventhandlers onLoadCont cid undef clval world
	# world = addCSSFromUrl "codemirror.css" world
	# world = addJSFromUrl "codemirror.js" Nothing world
	# world = addJSFromUrl "addon/mode/loadmode.js" (Just (hndCreator onLoadWrapper cid)) world
    = (clval,world)

onLoad hndCreator eventhandlers cont cid _ clval=:{val={source,configuration}} 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, marks = []}
	# world 			= manageSystemEvents "on" st world	
	# world 			= foldl (putOnEventHandler cm) world eventhandlers

    # (tasklets,world)  = findObject "itwc.controller.tasklets" world
    # (editlets,world)  = findObject "itwc.controller.editlets" world    
    # (cmp,world)       = .? (tasklets .# cid) world
    # (cmp,world)       = if (jsIsUndefined cmp) (.? (editlets .# cid) world) (cmp,world)
    # (clval,world)		= onAfterShow cm cid undef clval world
    # world             = (cmp .# "afterResize" .= (toJSVal (hndCreator (onAfterShow cm) cid))) world
    # world             = (cmp .# "afterShow" .= (toJSVal (hndCreator (onAfterShow cm) cid))) world        
	
    //Call continuation to initialize the editor	
    = cont cid {clval & mbSt = Just st} 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, world)

	putOnEventHandler cm world (event, handler)
		= snd (callObjectMethod "on" [toJSArg event, toJSArg (hndCreator handler cid)] cm world)

	systemEvents = [("cursorActivity",	hndCreator onCursorActivity cid),
					("change",			hndCreator 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])

        = ({clval & val={clval.val & source = lines}}, 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)}
		
		= ({clval & val = val}, world)

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

codeMirrorUIDef :: a [TaskletEvent b] -> TaskletHTML b | toString a
codeMirrorUIDef cid eventHandlers
	= { TaskletHTML
	  | 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;"] []]
	  , eventHandlers 	= eventHandlers
	  , width 			= ExactSize 300
	  , height			= ExactSize 300
	  }

codeMirrorTasklet :: !CodeMirror
				  -> Tasklet CodeMirrorClient CodeMirror
codeMirrorTasklet g = 
				{ Tasklet 
				| genUI      = \tid _ world -> (TaskletHTML (codeMirrorUIDef tid eventHandlers), {val = g, mbSt = Nothing}, world)
				, resultFunc = \clval -> Value clval.val False
				, tweakUI    = id
				}
where
	eventHandlers = [TaskletEvent "tasklet" "init" onInit]

	onInit taskId _ clval world
		= onInitClient foo [] onLoadWrapper onLoadCont (toString taskId) clval world 
    where
		onLoadCont taskId clval world = onUpdate taskId clval world 
		onLoadWrapper taskId obj st world = onLoad foo [] onLoadCont (toString taskId) obj st world
		foo hnd taskId = createTaskletEventHandler (\taskId obj val st -> hnd (toString taskId) obj val st) (fromString taskId)

	onUpdate taskid clval=:{val={source,configuration,position,selection,highlighted}, mbSt=Just st=:{codeMirror,marks}} world 
		// disable system event handlers
		# world = manageSystemEvents "off" st world		
	
		# world = setOptions configuration codeMirror world
		# world = loadModulesIfNeeded configuration codeMirror world
		
		# (cmdoc, world) = callObjectMethod "getDoc" [] codeMirror world

		# world = applyDiffClient cmdoc 0 0 source world
			
		# (pos, world) = tupleToPos position world 
		# world = snd (callObjectMethod "setCursor" [toJSArg pos] cmdoc world)		
	
		# world = case selection of
			Nothing	
				= world
			(Just (idx1,idx2))
				# (pos1, world) = tupleToPos idx1 world 
				# (pos2, world) = tupleToPos idx2 world 							
				= snd (callObjectMethod "setSelection" [toJSArg pos1, toJSArg pos2] cmdoc world)	

		// Set marks	
		# (marks, world) =
			foldl (\(ms, world) pos -> let (m,w) = addMark cmdoc pos world in ([m:ms], w)) ([], world) highlighted	
	
		// enable system event handlers
		# world = manageSystemEvents "on" st world
					
		= ({clval & mbSt = Just {st & marks = marks}}, world)				

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 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 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 (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