implementation module osprint

import StdArray, StdBool, StdEnum, StdFile, StdFunc, StdInt, StdList, StdMisc, StdTuple
import clCCall_12,clCrossCall_12, iostate, scheduler
import ospicture, osevent, StdWindow, StdPSt
import code from "cCrossCallPrinter_121.o",
				 "cprinter_121.o"

::	PrintSetup
	=	{	devmode		:: !String
		,	device		:: !String	// device, driver & output strings are null terminated
		,	driver		:: !String
		,	output		:: !String
		}
::	JobInfo
	=	{	range		:: !(!Int,!Int)
		,	copies		:: !Int
		}
::	PrintInfo
	=	{	printSetup	:: PrintSetup
		,	jobInfo		:: JobInfo
		}
::	Alternative x y
	=	Cancelled x
	|	StartedPrinting y


os_installprinter :: !*OSToolbox -> *OSToolbox
os_installprinter _
	= code
	{
		.inline InstallCrossCallPrinter
			ccall InstallCrossCallPrinter "I-I"
		.end
	}


os_getpagedimensions :: !PrintSetup !Bool -> (!(!Int,!Int), !(!(!Int,!Int),!(!Int,!Int)), !(!Int,!Int))
os_getpagedimensions { devmode, device, driver } emulateScreenRes
	= os_getpagedimensionsC devmode device driver emulateScreenRes

os_defaultprintsetup :: !*env -> (!PrintSetup, !*env)
os_defaultprintsetup env
	#	(dmSize,printerHandle,device,driver,output,env)	= getDevmodeSizeC env
	|	dmSize==0
		= ({devmode="\0", device="\0", driver="\0", output="\0"},env)
	#	devmode			= createArray dmSize ' '
		devmode			= { devmode & [dec dmSize]='\0'}
		env				= getDefaultDevmodeC devmode printerHandle device env	// alters contents of printSetup
	= ({devmode=devmode, device=device, driver=driver, output=output}, env)

printSetupDialogBoth :: !PrintSetup !(Maybe *Context) -> (!PrintSetup, !Maybe *Context)
printSetupDialogBoth print_setup=:{devmode,device,driver,output} mb_context
	# (os, mb_context)				= EnvGetOS mb_context
	# os							= os_installprinter os
	# (devmodePtr,os)				= winMakeCString devmode os
	# (devicePtr, os)				= winMakeCString device os
	# (driverPtr, os)				= winMakeCString driver os
	# (outputPtr, os)				= winMakeCString output os
	# (ok, pdPtr, mb_context, os)	= CCPrintSetupDialog mb_context (size devmode) devmodePtr devicePtr driverPtr outputPtr os
	# os							= winReleaseCString devmodePtr os
	# os							= winReleaseCString devicePtr os
	# os							= winReleaseCString driverPtr os
	# os							= winReleaseCString outputPtr os
	| ok==0
		# os						= release_memory_handles pdPtr os
		= (print_setup, EnvSetOS os mb_context)
	| otherwise
		# ((ndevmode,ndevice,ndriver,noutput),os)
									= get_printSetup_with_PRINTDLG pdPtr os
		# os						= release_memory_handles pdPtr os
		= ({devmode=ndevmode,device=ndevice,driver=ndriver,output=noutput}, EnvSetOS os mb_context)

os_printsetupvalid :: !PrintSetup !*env -> (!Bool, !*env)
os_printsetupvalid {devmode,device,driver} env
	= os_printsetupvalidC devmode device driver env

os_printsetupvalidC :: !String !String !String!*env -> (!Bool, !*env)
os_printsetupvalidC _ _ _ _
	= code
		{
			ccall os_printsetupvalidC "SSS:I:A"
		}

class PrintEnvironments printEnv where
	os_printpageperpage :: !Bool !Bool 
						   !.x
						   .(.x -> .(PrintInfo -> .(*Picture -> *((.Bool,Point2),*(.state,*Picture)))))
						   (*(.state,*Picture) -> *((.Bool,Point2),*(.state,*Picture)))
						   !PrintSetup !*printEnv
						-> (Alternative .x .state,!*printEnv)
	os_printsetupdialog	::  !PrintSetup !*printEnv
						-> (!PrintSetup,!*printEnv)


instance PrintEnvironments (PSt .l) where
	os_printpageperpage doDialog emulateScreen x initFun transFun printSetup pSt=:{io}
		#!	(windowStack, io)			= getWindowStack io
			windowStackIds				= map fst windowStack
			(zippedWithSelectState, io)	= seqList (map zipWithSelectState windowStackIds) io
			activeWindowIds				= [ id \\ (mbSelectState, id) <- zippedWithSelectState | isEnabled mbSelectState]
			io							= seq (map disableWindow activeWindowIds) io
			(result, pSt)				= accContext accFun { pSt & io=io }
			pSt							= appPIO (seq (map enableWindow activeWindowIds)) pSt
		= (result, pSt)
	where
		accFun context
			# (os, context)		= EnvGetOS context
			# os				= os_installprinter os
			# (x,mb_context,os)	= printPagePerPageBothSemaphor
									doDialog emulateScreen x initFun transFun printSetup (Just context) os
			= (x,EnvSetOS os (fromJust mb_context))
		
		zipWithSelectState :: Id (IOSt .l) -> (v:(Maybe SelectState,Id),IOSt .l)
		zipWithSelectState id io
			#!	(mbSelectState, io)	= getWindowSelectState id io
			= ((mbSelectState, id), io)
		
		isEnabled (Just Able)	= True
		isEnabled _				= False
	
	os_printsetupdialog printSetup pSt
		= accContext (accFun printSetup) pSt
	where
		accFun printSetup context
			# (printSetup, Just context) = printSetupDialogBoth printSetup (Just context)
			= (printSetup, context)



instance PrintEnvironments Files where
	os_printpageperpage doDialog emulateScreen x initFun transFun printSetup files
		# (os, files)	= EnvGetOS files
		# os			= os_installprinter os
		# (x,_,os)		= printPagePerPageBothSemaphor
		  					doDialog emulateScreen x initFun transFun printSetup Nothing os
		= (x, EnvSetOS os files) 
	
	os_printsetupdialog printSetup files
		# (printSetup, _) = printSetupDialogBoth printSetup Nothing
		= (printSetup, files) // oh lala
		

printPagePerPageBothSemaphor :: !Bool !Bool .a
								.(.a -> .(.PrintInfo -> .(*Picture -> *((Bool,Origin),*(.b,*Picture)))))
								(*(.b,*Picture) -> *((Bool,Origin),*(.b,*Picture)))
								!PrintSetup *(Maybe *Context) !*OSToolbox
							-> *(*(Alternative .a .b),*(Maybe *Context),!*OSToolbox)
printPagePerPageBothSemaphor p1 p2 x p4 p5 printSetup mb_context os
// with this mechanism it is assured, that only one print job can happen at a time
// addSemaphor adds the parameter to a C global and gives back the previous value of that
// global
	# (s,os) = addSemaphor 1 os
	| s>0 
		# (_,os) = addSemaphor (-1) os
		= (Cancelled x,mb_context,os)
	# (result,mb_context,os) = printPagePerPageBoth p1 p2 x p4 p5 printSetup mb_context os
	  (_,os) = addSemaphor (-1) os
	= (result,mb_context,os)

printPagePerPageBoth :: !Bool !Bool .a
						.(.a -> .(.PrintInfo -> .(*Picture -> *((Bool,Origin),*(.b,*Picture))))) 
						(*(.b,*Picture) -> *((Bool,Origin),*(.b,*Picture))) 
						PrintSetup *(Maybe *Context) !*OSToolbox
					-> *(*(Alternative .a .b),*(Maybe *Context),!*OSToolbox)
printPagePerPageBoth doDialog emulateScreen x initFun transFun printSetup mb_context os
	  // do the print dialog (or not) and get the hdc and the printInfo

	  # (err, hdc, printInfo, mb_context, os) 
	  		= getPrintInfo doDialog emulateScreen printSetup mb_context os

	  | err == 4107 // this error occurs, when the printsetup contains bad values
			# (defaultPS, os)	= os_defaultprintsetup os
			= printPagePerPageBoth doDialog emulateScreen x initFun transFun defaultPS mb_context os
			
	  // check, whether the user canceled

	  | err >= 0 = (Cancelled x, mb_context, os)

	  // call StartDoc either via the OS thread or direct

	  #	(err, mb_context, os) = CCstartDoc hdc mb_context os
  
	  | err <= 0 = (Cancelled x, mb_context, deleteDC hdc os)
			// user canceled printing to file from file dialog
  
	  // initialise printer picture and call the initFun function

	  # picture = initPicture zeroOrigin (hdc,os)
	    (endOrig,(initState,picture)) = initFun x printInfo picture
 	    (_,_,_,hdc,os) = unpackPicture picture

	  // now print all pages
  
	  # (finalState,hdc,mb_context,os)
	  		= printPages 0 transFun endOrig initState hdc mb_context os

	  // Sluit af

	    (mb_context, os) = CCendDoc hdc mb_context os
	  = (StartedPrinting finalState, mb_context, (deleteDC hdc os))

printPages :: Int
			(*(.a,*Picture) -> *((Bool,Origin),* (.a,*Picture)))
			(Bool,Origin) .a HDC *(Maybe *Context) !*OSToolbox
		-> *(.a,HDC,*(Maybe *Context),!*OSToolbox)
printPages _ _ (True,_) state hdc mb_context os
  =(state,hdc,mb_context,os)
printPages pageNr fun (_,origin) state hdc mb_context os

  // give OS thread eventually a chance to handle events
  # (mb_context,os) = evtlSwitchToOS pageNr hdc mb_context os
  
  #	(ok, os)	= startPage hdc os
  | ok == 0 = abort "\nPrint08: Failed in \"StartPage\". Probably not enough memory."
  #	picture = initPicture origin (hdc,os)
  // apply drawfunctions contained in this page
	((endOfDoc,nextOrigin),(state`,picture))	= fun (state,picture)
  // finish drawing
  # (_,_,_,hdc,os)	= unpackPicture picture
   	(ok, os)	= endPage hdc os
    // (not ok) should not cause an abort, because endPage returns an error, when user chooses
  	// "encapsulated postscript" as output format and the output is longer than one page.
  	// This situation can't be retrieved from the "GetLastError" code. An abort should not occur. 
	(canceled,os)	= wasCanceled os
	// draw rest of pages
  =	printPages (inc pageNr) fun (endOfDoc || canceled || (ok==0),nextOrigin)  state` hdc mb_context os
      
zeroOrigin :== zero  		

///////////////////////////////////////////////////////////////////////////////

getPrintInfo :: !.Bool !.Bool .PrintSetup *(Maybe *Context) !*OSToolbox
			 -> *(Int,Int,.PrintInfo,*Maybe *Context,!.OSToolbox);
getPrintInfo doDialog emulateScreen {devmode, device, driver, output} mb_context os
	# (devmodePtr,os) = winMakeCString devmode os
	  (devicePtr,os) = winMakeCString device os
	  (driverPtr,os) = winMakeCString driver os
	  (outputPtr,os) = winMakeCString output os
	  ( err, data, pdPtr, mb_context, os)
	  		= CCgetDC	(if doDialog 1 0) (if emulateScreen 2 0)	// these two bits will be packed into one word in CCgetDC
						(size devmode) devmodePtr devicePtr driverPtr outputPtr mb_context os
	  os = winReleaseCString devmodePtr os
	  os = winReleaseCString devicePtr os
	  os = winReleaseCString driverPtr os
	  os = winReleaseCString outputPtr os
	| doDialog && (err==(-1))
		# (setup_strings, os) = get_printSetup_with_PRINTDLG pdPtr os
		  os = release_memory_handles pdPtr os
		= continuation err data mb_context (setup_strings, os)
	= continuation err data mb_context ((devmode,device,driver,output),os)
  where
	continuation err (first,last,copies,hdc) mb_context ((devmode,device,driver,output),os)
		# first` = max 1 first
		  last` = max first` last
		  copies` = max 1 copies
		= ( err,
		    hdc,
		    {	printSetup	= { devmode=devmode, device=device ,driver=driver, output=output },
   			  	jobInfo		= {	range = (first`,last`),
   	    						copies = copies`
   	    					  }
 		     },
		     mb_context,
 		   	 os
   		   )

handleContextOSEvent` :: !OSEvent !Context !*OSToolbox -> (!CrossCallInfo,!Context,!*OSToolbox)
handleContextOSEvent` osEvent context tb
	# (return,context) = handleContextOSEvent osEvent context
	= (setReplyInOSEvent return,context,tb)


CCgetDC :: !.Int !.Int !.Int !.Int !.Int !.Int !.Int !*(Maybe *Context) !*OSToolbox -> *(!Int,!(!Int,!Int,!Int,!Int),!Int,!*Maybe *Context,!.OSToolbox);
CCgetDC doDialog emulateScreen devmodeSize devmodePtr devicePtr driverPtr outputPtr Nothing os
	# (ok,first,last,copies,pdPtr,deviceContext,os)
		= getDC doDialog emulateScreen 1 devmodeSize devmodePtr devicePtr driverPtr outputPtr os
	= (ok,(first,last,copies,deviceContext),pdPtr,Nothing,os)
CCgetDC doDialog emulateScreen devmodeSize devmodePtr devicePtr driverPtr outputPtr (Just context) os
	# createcci = Rq6Cci 	CcRqGET_PRINTER_DC (doDialog bitor emulateScreen) devmodeSize
							devmodePtr devicePtr driverPtr outputPtr
	# (rcci, context, os)  = issueCleanRequest handleContextOSEvent` createcci context os
	= (	rcci.p1, (rcci.p2, rcci.p3, rcci.p4,rcci.p6), rcci.p5,
////////err,	 (first,   last,    copies, deviceContext),pdPtr,
		Just context,os
	  )

CCPrintSetupDialog :: !(Maybe *Context) !.Int !.Int !.Int !.Int !.Int !*OSToolbox -> (!OkReturn,!Int,!Maybe *Context, !.OSToolbox);
CCPrintSetupDialog nothing=:Nothing devmodeSize devmodePtr devicePtr driverPtr outputPtr os
	# (ok, pdPtr, os) = printSetup 1 devmodeSize devmodePtr devicePtr driverPtr outputPtr os
	= (ok, pdPtr, nothing, os)
CCPrintSetupDialog (Just context) devmodeSize devmodePtr devicePtr driverPtr outputPtr os
	# createcci				= Rq5Cci CcRqDO_PRINT_SETUP devmodeSize devmodePtr devicePtr driverPtr outputPtr
	  (rcci, context, os)	= issueCleanRequest handleContextOSEvent` createcci context os
	= (rcci.p1, rcci.p2, Just context, os)
/* MW was
CCPrintSetupDialog :: !.Bool .Int .Int .Int .Int .Int !*OSToolbox -> (OkReturn,Int,!.OSToolbox);
CCPrintSetupDialog True devmodeSize devmodePtr devicePtr driverPtr outputPtr os
	= printSetup 1 devmodeSize devmodePtr devicePtr driverPtr outputPtr os
CCPrintSetupDialog False devmodeSize devmodePtr devicePtr driverPtr outputPtr os
	# createcci = Rq5Cci CcRqDO_PRINT_SETUP devmodeSize devmodePtr devicePtr driverPtr outputPtr
	  (rcci, os)  = issueCleanRequest2 (ErrorCallback2 "ERROR in osPrint08") createcci os
	  (rcci, os)  = issueCleanRequest2 handleContextOSEvent` createcci os
	= (rcci.p1, rcci.p2, os)
*/

CCstartDoc :: !.HDC !*(Maybe *Context) !*OSToolbox -> *(!Int,!*Maybe *Context,!*OSToolbox)
// error code: -1:no error, 0: user canceled file dialog, others: other error
CCstartDoc hdc Nothing os
	# (err,os) = startDoc hdc os
	= (err,Nothing,os)
CCstartDoc hdc (Just context) os
	# createcci = Rq1Cci CcRqSTARTDOC hdc
	  (rcci,context, os)  = issueCleanRequest handleContextOSEvent` createcci context os
	= (rcci.p1, Just context, os)

CCendDoc :: !.HDC !*(Maybe *Context) !*OSToolbox -> *(!*Maybe *Context,!*OSToolbox)
CCendDoc hdc Nothing os
	# os = endDoc hdc os
	= (Nothing,os)
CCendDoc hdc (Just context) os
	# createcci = Rq1Cci CcRqENDDOC hdc
	  (_,context, os)  = issueCleanRequest handleContextOSEvent` createcci context os
	= (Just context,os)

evtlSwitchToOS :: !Int !.Int !*(Maybe *Context) !*OSToolbox -> *(!*Maybe *Context,!.OSToolbox)
evtlSwitchToOS _ _ Nothing os
	= (Nothing,os)
evtlSwitchToOS pageNr hdc (Just context) os
	# nrStr = toString pageNr
	# messageText = if (pageNr==0)	""
									(nrStr+++" page"+++(if (pageNr==1) "" "s")+++" printed")
	# (textPtr,os) = winMakeCString messageText os
	# createcci = Rq1Cci CcRqDISPATCH_MESSAGES_WHILE_PRINTING textPtr
	# (_,context, os)  = issueCleanRequest handleContextOSEvent` createcci context os
	# os = winReleaseCString textPtr os
	= (Just context, os) 

initPicture :: !.Origin !*(!.OSPictContext,!*OSToolbox) -> *Picture
initPicture origin intPict
 = packPicture origin defaultPen False (fst intPict) (snd intPict)
	

EnvGetOS :: !*env -> (!*OSToolbox,!*env)
EnvGetOS env
  = (42,env)

EnvSetOS :: !*OSToolbox !*env -> *env
EnvSetOS os env
  = env


//////////////////////////////////////////////////
//												//
//				C CALLING FUNCTIONS				//	
//												//
//////////////////////////////////////////////////

:: OkReturn :== Int		// okReturn<>0 <=> ok !

os_getpagedimensionsC	::	!String !String !String !Bool 
						->	(!(!Int,!Int), !(!(!Int,!Int),!(!Int,!Int)), !(!Int,!Int))
os_getpagedimensionsC _ _ _ _
	= code
		{
			ccall	os_getpagedimensionsC "SSSI-IIIIIIII"
		}
		
getDevmodeSizeC	::	!*env	-> (!Int,!Int,!String,!String,!String,!*env)
getDevmodeSizeC _
	= code
		{
			ccall getDevmodeSizeC ":VIISSS:A"
		}
		
getDefaultDevmodeC	::	!String !Int !String !*env	->	*env
getDefaultDevmodeC _ _ _ _
	= code
		{
			ccall getDefaultDevmodeC "SIS:V:A"
		}
		
printSetup	:: !Int !Int !Int !Int !Int !Int !*OSToolbox -> (!OkReturn,!Int,!*OSToolbox)
printSetup _ _ _ _ _ _ _
	= code
		{
			ccall printSetup "IIIIII:VII:I"
		}

get_printSetup_with_PRINTDLG	::	!Int !*OSToolbox -> (!(!String, !String, !String, !String), !*OSToolbox)
get_printSetup_with_PRINTDLG _ _
	= code
		{
			ccall get_printSetup_with_PRINTDLG "I:VSSSS:I"
		}

release_memory_handles :: !Int !*OSToolbox -> *OSToolbox
release_memory_handles _ _
	= code
		{
			ccall release_memory_handles "II-I"
		}

startPage :: !HDC !*OSToolbox -> (!OkReturn, !*OSToolbox)
startPage _ _
	= code
	{
			ccall startPage "I:I:I"
	}

endPage ::	!HDC !*OSToolbox -> (!OkReturn, !*OSToolbox)
endPage _ _
	= code
	{
			ccall endPage "I:I:I"
	}

startDoc :: !HDC !*OSToolbox -> (!Int, !*OSToolbox)
			// err code: >0:no error, <=0: user cancelled file dialog
startDoc _ _
	= code
	{
			ccall startDoc "I:I:I"
	}

endDoc :: !HDC !*OSToolbox -> *OSToolbox
endDoc _ _
	= code
	{
			ccall endDoc "I:V:I"
	}

wasCanceled :: !*OSToolbox -> (!Bool,!*OSToolbox)
wasCanceled _
	= code
	{
			ccall wasCanceled ":I:I"
	}

deleteDC :: !HDC !*OSToolbox -> *OSToolbox
deleteDC _ _
	= code
	{
			ccall deleteDC "I:V:I"
	}


getDC :: !Int !Int !Int !Int !Int !Int !Int !Int !*OSToolbox -> (!Int, !Int, !Int, !Int, !Int, !Int, !*OSToolbox)
// getDC doDialog emulateScreen "getDC called directly from CleanThread" devmodeSize
// first element of result is an error code:
// -1:no error, others: non fatal error
getDC _ _ _ _ _ _ _ _ _
	= code
	{
			ccall getDC "IIIIIIII:VIIIIII:I"
	}

addSemaphor :: !Int !*OSToolbox  -> (!Int,!*OSToolbox)
addSemaphor _ _
	= code
	{
			ccall addSemaphor "I:I:I"
	}

os_printsetuptostring	::	!PrintSetup -> String
os_printsetuptostring {devmode, device, driver, output}
	=		toString (size devmode)+++" "+++toString (size device)+++" "+++toString (size driver)+++" "
		 +++devmode+++device+++driver+++output

os_stringtoprintsetup	::	!String -> PrintSetup
os_stringtoprintsetup string
	#!	chList	= [ch \\ ch<-:string]
		(sizeChLists, rest)	= seqList (repeatn 3 (splitInt [])) chList
		sizes	= map (toInt o toString) sizeChLists
		(devmodeSize, deviceSize, driverSize)	= listTo3Tuple sizes
		devmode	= toString (rest % (0, devmodeSize-1))
		driverStartIndex = devmodeSize+deviceSize
		device	= toString (rest % (devmodeSize, driverStartIndex-1))
		outputStartIndex	= driverStartIndex+driverSize
		driver	= toString (rest % (driverStartIndex, outputStartIndex-1))
		output	= toString (rest % (outputStartIndex, (size string)-1))
	|		size devmode==devmodeSize && size device==deviceSize
		&&	size driver==driverSize && size output==(length rest)-outputStartIndex
		&&	devmodeSize>0 && deviceSize>0 && driverSize>0 && size output>0
		= {devmode=devmode, device=device, driver=driver, output=output}
	= {devmode="\0", device="\0", driver="\0", output="\0"}
  where
	splitInt akku []
		= (reverse akku, [])
	splitInt akku [ch:chs]
		|	isDigit ch
			= splitInt [ch:akku] chs
		= (reverse akku, chs)
	listTo3Tuple [e1,e2,e3] = (e1,e2,e3)