implementation module compile

import StdEnv
import frontend
import backendinterface
import filesystem, CoclSystemDependent

from CoclSystemDependent import DirectorySeparator, ensureCleanSystemFilesExists

baseName :: {#Char} -> {#Char}
baseName path
	=	last (splitBy DirectorySeparator path)

directoryName :: {#Char} -> {#Char}
directoryName path
	=	foldr (\p ps -> p +++ {DirectorySeparator} +++ ps) "" (init (splitBy DirectorySeparator path))
	
splitBy :: Char {#Char} -> [{#Char}]
splitBy char string
	=	splitBy` 0 0
	where
		splitBy` frm to
			| to >= stringSize
				=	[string % (frm, to-1)]
			| string.[to] == char
				=	[string % (frm, to-1) : splitBy` (to+1) (to+1)]
			// otherwise
				=	splitBy` frm (to+1)
		stringSize
			=	size string

make_clean_system_files_dir_and_file_name :: !{#Char} -> (!{#Char},!{#Char})
make_clean_system_files_dir_and_file_name dir_and_module_name
	# last_dir_separator_i = find_last_dir_separator_i dir_and_module_name
	# last_dot_i = find_last_dot_i last_dir_separator_i dir_and_module_name
	| last_dot_i<0
		= ("Clean System Files",dir_and_module_name)
	# module_name = dir_and_module_name % (last_dot_i+1,size dir_and_module_name-1)
	| last_dir_separator_i<0
		# subdir_name = {let c=dir_and_module_name.[i] in if (c=='.') DirectorySeparator c \\ i<-[0..last_dot_i-1] }
		= (subdir_name +++ {DirectorySeparator} +++ "Clean System Files", module_name)
	# dir = dir_and_module_name % (0,last_dir_separator_i)
	| last_dot_i==last_dir_separator_i
		= (dir +++ "Clean System Files", module_name)
		# subdir_name = {let c=dir_and_module_name.[i] in if (c=='.') DirectorySeparator c \\ i<-[last_dir_separator_i+1..last_dot_i-1] }
		= (dir +++ subdir_name +++ {DirectorySeparator} +++ "Clean System Files", module_name)
where
	find_last_dir_separator_i s
		= find_last_dir_separator_i s (size s-1)
	where
		find_last_dir_separator_i s i
			| i>=0 && s.[i]<>DirectorySeparator
				= find_last_dir_separator_i s (i-1)
				= i

	find_last_dot_i last_dir_separator_i s
		= find_last_dot_i s (size s-1)
	where
		find_last_dot_i s i
			| i>last_dir_separator_i && s.[i]<>'.'
				= find_last_dot_i s (i-1)
				= i

openTclFile :: !String !String !*File !*Files -> (!Bool, !Optional .File, !*File, !*Files)
openTclFile mod_dir mod_name error files
	= open_file_in_clean_system_files_folder mod_dir mod_name ".tcl" FWriteData error files

open_file_in_clean_system_files_folder :: !String !String !String !Int !*File !*Files -> (!Bool, !Optional .File, !*File, !*Files)
open_file_in_clean_system_files_folder mod_dir mod_name file_extension file_mode error files
	# icl_mod_pathname = mod_dir +++ {DirectorySeparator} +++ mod_name;
	# (csf_directory_path,file_name) = make_clean_system_files_dir_and_file_name icl_mod_pathname
	# file_path = csf_directory_path +++ {DirectorySeparator} +++ file_name +++ file_extension
	# (opened, tcl_file, files)
		= fopen file_path file_mode files
	| opened
		= (True, Yes tcl_file, error, files)
	// try again after creating Clean System Files folder
	# (ok, files)
		= ensureCleanSystemFilesExists csf_directory_path files
	| not ok
		# error = fwrites ("can't create folder \"" +++ csf_directory_path +++"\"\n") error
		= (False, No, error, files)
	# (opened, tcl_file, files)
		= fopen file_path file_mode files
	| not opened
		# error = fwrites ("couldn't open file \"" +++ file_path +++ "\"\n") error
		= (False, No, error, files)
	= (True, Yes tcl_file, error, files)

closeTclFile :: !*(Optional *File) *Files -> *(!Bool,*Files)
closeTclFile (Yes tcl_file) files
	= fclose tcl_file files
closeTclFile _ files
	= (True,files);

abc_file_name_in_clean_system_files_folder :: !String !String !*File !*Files -> (!Bool, !String, !*File, !*Files)
abc_file_name_in_clean_system_files_folder mod_dir mod_name error files
	// mod_dir ends with DirectorySeparator
	# (csf_directory_path,file_name) = make_clean_system_files_dir_and_file_name (mod_dir +++ mod_name)
	# file_path = csf_directory_path +++ {DirectorySeparator} +++ file_name +++ ".abc"
	# (ok, files) = ensureCleanSystemFilesExists csf_directory_path files
	| not ok
		# error = fwrites ("can't create folder \"" +++ csf_directory_path +++"\"\n") error
		= (False, file_path, error, files)
	= (True, file_path, error, files)

::	CoclOptions =
	{	moduleName:: {#Char}
	,	pathName ::{#Char}
	,	outputPathName ::{#Char}
	,	errorPath:: {#Char}
	,	errorMode::	Int
	,	outPath:: {#Char}
	,	outMode::	Int
	,	searchPaths:: SearchPaths
	,	listTypes :: ListTypesOption
	,	fusion_options :: !FusionOptions
	,	compile_for_dynamics	:: !Bool
	,	generate_tcl_file :: !Bool
	}

StdErrPathName :== "_stderr_"
StdOutPathName :== "_stdout_"

InitialCoclOptions =
	{	moduleName=	""
	,	pathName=	""
	,	outputPathName=	""
	,	errorPath=	StdErrPathName
	,	errorMode=	FWriteText
	,	outPath=	StdErrPathName
	,	outMode=	FWriteText
	,	searchPaths=	{sp_locations = [], sp_paths = []}
	,	listTypes = {lto_showAttributes = True, lto_listTypesKind = ListTypesNone}
	,	fusion_options = {compile_with_fusion = False, generic_fusion = False, strip_unused = False}
	,	compile_for_dynamics	= False
	,	generate_tcl_file = False
	}

:: DclCache = {
	dcl_modules::!{#DclModule},
	functions_and_macros::!.{#.{#FunDef}},
	predef_symbols::!.PredefinedSymbols,
	hash_table::!.HashTable,
	heaps::!.Heaps
 };

empty_cache :: !*SymbolTable -> *DclCache
empty_cache symbol_heap
	# heaps = {hp_var_heap = newHeap, hp_expression_heap = newHeap, hp_type_heaps = {th_vars = newHeap, th_attrs = newHeap}, hp_generic_heap = newHeap}
	# (predef_symbols, hash_table) = buildPredefinedSymbols (newHashTable symbol_heap)
	= {dcl_modules={},functions_and_macros={},predef_symbols=predef_symbols,hash_table=hash_table,heaps=heaps}

compile :: ![{#Char}] !*DclCache !*Files -> (!Bool,!*DclCache,!*Files)
compile args cache files
	# (args_without_modules,modules,cocl_options) = parseCommandLine args InitialCoclOptions
	= compile_modules modules 0 cocl_options args_without_modules cache files;

// WARNING:
// if you add an option which is not supported by the backend, then you should remove it from
// the first list in the tuple returned by parseCommandLine
parseCommandLine :: [{#Char}] CoclOptions -> ([{#Char}],[{#Char}],CoclOptions)
parseCommandLine [] options
	=	([],[],options)
parseCommandLine [arg1=:"-o", outputPathName : args] options=:{searchPaths}
	= parseCommandLine args {options & outputPathName = outputPathName}
parseCommandLine [arg1=:"-P", searchPathsString : args] options=:{searchPaths}
	= parseCommandLine args {options & searchPaths.sp_paths = splitPaths searchPathsString}
parseCommandLine [arg1=:"-RO", outPath : args] options
	# (args,modules,options)=	parseCommandLine args {options & outPath = stripQuotes outPath, outMode = FWriteText}
	= ([arg1,outPath:args],modules,options)
parseCommandLine [arg1=:"-RAO", outPath : args] options
	# (args,modules,options)=	parseCommandLine args {options & outPath = stripQuotes outPath, outMode = FAppendText}
	= ([arg1,outPath:args],modules,options)
parseCommandLine [arg1=:"-RE", errorPath : args] options
	# (args,modules,options)=	parseCommandLine args {options & errorPath = stripQuotes errorPath, errorMode = FWriteText}
	= ([arg1,errorPath:args],modules,options)
parseCommandLine [arg1=:"-RAE", errorPath : args] options
	# (args,modules,options)=	parseCommandLine args {options & errorPath = stripQuotes errorPath, errorMode = FAppendText}
	= ([arg1,errorPath:args],modules,options)
/* RWS FIXME: "-id" option is only used for the Mac version
   and should be moved elsewhere
*/
parseCommandLine ["-id",compiler_id_string : args] options
	# compiler_id=toInt compiler_id_string
	| set_compiler_id compiler_id==compiler_id
		= parseCommandLine args options
parseCommandLine [arg1=:"-dynamics":args] options
	// generates for each .icl module a .tcl file (which contains the type information for that module)
	# (args,modules,options) = parseCommandLine args {options & compile_for_dynamics = True}
	= ([arg1:args],modules,options)
parseCommandLine [arg1=:"-fusion":args] options
	// switch on fusion transformations
	# (args,modules,options) = parseCommandLine args {options & fusion_options.compile_with_fusion = True}
	= ([arg1:args],modules,options)
parseCommandLine [arg1=:"-generic_fusion":args] options
	# (args,modules,options) = parseCommandLine args {options & fusion_options.generic_fusion = True}
	= ([arg1:args],modules,options)
parseCommandLine [arg1=:"-strip":args] options
	// ignored
	= parseCommandLine args options
parseCommandLine ["-generics":args] options
	// enable generics
	= parseCommandLine args options
parseCommandLine ["-lattr":args] options
	= parseCommandLine args {options & listTypes.lto_showAttributes = False}
parseCommandLine ["-lt":args] options
	= parseCommandLine args {options & listTypes.lto_listTypesKind = ListTypesInferred}
parseCommandLine ["-lset":args] options
	= parseCommandLine args {options & listTypes.lto_listTypesKind = ListTypesStrictExports}
parseCommandLine ["-lat":args] options
	= parseCommandLine args {options & listTypes.lto_listTypesKind = ListTypesAll}
parseCommandLine [arg1=:"-tcl":args] options
	# (args,modules,options) = parseCommandLine args {options & generate_tcl_file = True, compile_for_dynamics = True}
	= ([arg1:args],modules,options)
parseCommandLine [arg : args] options
	| arg.[0] == '-'
		# (args,modules,options)=	parseCommandLine args options
		= ([arg:args],modules,options)
	// otherwise
		# (args,modules,options) = parseCommandLine args options
		= (args,[arg : modules],options);

stripExtension :: {#Char} {#Char} -> {#Char}
stripExtension extension string
	| stringSize >= extensionSize && (string % (stringSize-extensionSize, stringSize-1)) == extension
		=	string % (0, stringSize-extensionSize-1)
	// otherwise
		=	string
	where
		stringSize
			=	size string
		extensionSize
			=	size extension

stripQuotes :: {#Char} -> {#Char}
stripQuotes string
	| stringSize > 1 && string.[0] == '"' && string.[stringSize-1] == '"'
		=	string % (1, stringSize-2)
	// otherwise
		=	string
	where
		stringSize
			=	size string

splitPaths :: {#Char} -> [{#Char}]
splitPaths paths
	=	[path +++ {DirectorySeparator} \\ path <- splitBy PathSeparator paths]

compile_modules [module_:modules] n_compiles cocl_options args_without_modules cache files
	# pathName = stripExtension ".icl" (stripQuotes module_)
	# cocl_options & pathName=pathName, moduleName = baseName pathName
	# (ok,cache,files)
		= compileModule cocl_options args_without_modules cache files;
	| ok
		= compile_modules modules (n_compiles+1) cocl_options args_without_modules cache files;
		= (ok,cache,files);
compile_modules [] n_compiles cocl_options args_without_modules cache files
	= (True,cache,files);

openPath :: {#Char} Int *Files -> (Bool, *File, *Files)
openPath path mode files
	| path == StdErrPathName
		=	(True, stderr, files)
	| path == StdOutPathName
		# (io, files)
			=	stdio files
		=	(True, io, files)
	// otherwise
		=	fopen path mode files

compileModule :: CoclOptions [{#Char}] *DclCache *Files -> (!Bool,!*DclCache,!*Files)
compileModule options backendArgs cache=:{dcl_modules,functions_and_macros,predef_symbols,hash_table,heaps} files	
	# (opened, error, files)
		=	openPath options.errorPath options.errorMode files
	| not opened
		=	abort ("couldn't open error file \"" +++ options.errorPath +++ "\"\n")
	# (opened, out, files)
		=	openPath options.outPath options.outMode files
	| not opened
		=	abort ("couldn't open out file \"" +++ options.outPath +++ "\"\n")
	# (opt_file_dir_time,files) = fopenInSearchPaths options.moduleName ".icl" options.searchPaths FReadData fmodificationtime files
	# (opt_file_dir_time, mbModPath) = 
			case opt_file_dir_time of
				Yes (_,mod_path,_) = (opt_file_dir_time, Yes mod_path)
				No				   = (opt_file_dir_time, No)
	# (optional_tcl_opened, tcl_file, error, files)
		= case mbModPath of
			Yes mod_path
				| options.generate_tcl_file
					-> openTclFile mod_path options.moduleName error files
			_
				-> 	(True,No,error,files)
	| not optional_tcl_opened
		# (closed, files) = fclose out files
		| not closed
			=	abort ("couldn't close stdio")
		# (closed, files) = fclose error files
		| not closed
			=	abort ("couldn't close out file \"" +++ options.outPath +++ "\"\n")
		=	(False, cache, files)
	# (io, files) = stdio files
	# ({boxed_ident=moduleIdent}, hash_table) = putIdentInHashTable options.moduleName (IC_Module NoQualifiedIdents) hash_table
	# list_inferred_types
		=	if (options.listTypes.lto_listTypesKind == ListTypesInferred)
				(Yes options.listTypes.lto_showAttributes)
				No
	# (optionalSyntaxTree,cached_functions_and_macros,cached_dcl_mods,main_dcl_module_n,predef_symbols, hash_table, files, error, io, out,tcl_file,heaps)
		= frontEndInterface opt_file_dir_time {feo_up_to_phase=FrontEndPhaseAll,feo_fusion=options.fusion_options}
			moduleIdent options.searchPaths dcl_modules functions_and_macros list_inferred_types options.compile_for_dynamics fmodificationtime
			predef_symbols hash_table files error io out tcl_file heaps

	# unique_copy_of_predef_symbols={predef_symbol\\predef_symbol<-:predef_symbols}
	# (closed, files)
		= closeTclFile tcl_file files
	| not closed
		=   abort ("couldn't close tcl file \"" +++ options.pathName +++ "tcl\"\n")
	# (closed, files)
		=	fclose io files
	| not closed
		=	abort ("couldn't close stdio")
	# var_heap=heaps.hp_var_heap
	  hp_type_heaps=heaps.hp_type_heaps
	  type_var_heap=hp_type_heaps.th_vars
	  attrHeap=hp_type_heaps.th_attrs
	# (success,functions_and_macros,var_heap,type_var_heap,attrHeap,error,out,files)
		= case optionalSyntaxTree of
			Yes syntaxTree
				# functions_and_macros = syntaxTree.fe_icl.icl_functions
				  (Yes path) = mbModPath
				  (csf_dir_exists,abc_file_path,error,files)
					= if (size options.outputPathName==0)
						(abc_file_name_in_clean_system_files_folder path options.moduleName error files)
						(True,options.outputPathName,error,files)
				  (success,var_heap,type_var_heap,attrHeap,error,out,files)
					= backEndInterface abc_file_path (map appendRedirection backendArgs) options.listTypes options.outPath predef_symbols syntaxTree main_dcl_module_n
						   var_heap type_var_heap attrHeap error out files
				-> (success,functions_and_macros,var_heap,type_var_heap,attrHeap,error,out,files)
				with
					appendRedirection arg
						= case arg of
							"-RE"
								-> "-RAE"
							"-RO"
								-> "-RAO"
							arg
								->	arg
			No
				-> (False,{},var_heap,type_var_heap,attrHeap,error,out,files)
	# heaps = {heaps & hp_var_heap=var_heap, hp_type_heaps = {th_vars=type_var_heap, th_attrs=attrHeap}}
	# (closed, files) = fclose out files
	| not closed
		=	abort ("couldn't close out file \"" +++ options.outPath +++ "\"\n")
	# (closed, files)
		=	fclose error files
	| not closed
		=	abort ("couldn't close error file \"" +++ options.errorPath +++ "\"\n")
	| success
		# dcl_modules={{dcl_module \\ dcl_module<-:cached_dcl_mods} & [main_dcl_module_n].dcl_has_macro_conversions=False}
		# cache={dcl_modules=dcl_modules,functions_and_macros=cached_functions_and_macros,predef_symbols=unique_copy_of_predef_symbols,hash_table=hash_table,heaps=heaps}
		= (success,cache,files)
		# cache={dcl_modules=cached_dcl_mods,functions_and_macros=cached_functions_and_macros,predef_symbols=unique_copy_of_predef_symbols,hash_table=hash_table,heaps=heaps}
		= (success,cache,files)
