implementation module SaplLinkerShared

import StdEnv, StdMaybe
import SaplTokenizer, Map, StringAppender, FastString, SaplStdEnvDir
import Platform, File, Directory

instance toString LineType
where
	toString (LT_REDIRECT name) = name
	toString (LT_FUNC line _) = line
	toString (LT_MACRO line _) = line	

unpackName (TIdentifier name) = name
unpackName _ = ""

isGlobalFunction name = fst (charIndex name 1 '.') // first char can be skipped safely

// An identifier is a dependency if it contains a "."
generate_dependencies :: [Token] [String] -> [String]
generate_dependencies [TIdentifier name:ts] ds
	= if (isGlobalFunction name) (generate_dependencies ts [name:ds]) (generate_dependencies ts ds)
generate_dependencies [_:ts] ds = generate_dependencies ts ds
generate_dependencies [] ds = ds

read_modules :: [String] (Map String LineType) [String] !*World -> (Map String LineType, [String], Maybe String, !*World)
read_modules [m:ms] llmap messages world 
	= read_modules_ [m:ms] llmap messages Nothing 0 world
where 
	read_modules_ [m:ms] lmap messages startfn id world 
		# (ok, ma, world) = readFileArray m world
		| ok
			# (lmap, startfn, id) = foldl read_line (lmap, startfn, id) ma
			= read_modules_ ms lmap messages startfn id world
			= read_modules_ ms lmap ["Warning: " +++ m +++ " not found.":messages] startfn id world
		
	read_modules_ [] lmap messages startfn id world = (lmap, messages, startfn, world)

read_module :: !String (Map String LineType) [String] Int !*World -> (Map String LineType, Int, [String], !*World)
read_module m lmap messages id world
	# (ok, ma, world) = readFileArray m world
	| ok
		# (lmap, startfn, id) = foldl read_line (lmap, Just "dummy", id) ma
		= (lmap, id, messages, world)
		= (lmap, id, ["Warning: " +++ m +++ " not found.":messages], world)
		
/* three kind of lines:
 * :: test_B = test_C a1 | test_D
 * :: test__A = {a, b, c, d, e, f}
 * main a b = ...
 */

read_line (lmap, startfn, id) line 
	# ts = tokens line
	# next = tl ts
	= case hd ts of
			TTypeDef
				# type_name = unpackName (hd next)
				# next = tl next // skip type name	
				# next = tl next // skip "="													
				
				# lmap = case hd next of
							TOpenBracket # lmap = put type_name (LT_FUNC line DT_NO_DEPENDENCY) lmap
										 = parse_record (tl next) type_name lmap // constructors as redirects
										 
										 // For ADTs substitute type name with numeric id (only constructor names used,
										 // and the type name can be identical to one of its constructors name which is not good here)
							_			 # tid = "_"+++toString id
										 # lmap = put tid (LT_FUNC line DT_NO_DEPENDENCY) lmap
										 = parse_ADT next tid lmap
				= (lmap, startfn, id+1)
									
			(TIdentifier name)
				# lmap = case skip_to_definition next of
					[TAssignmentOp, (TIdentifier "StdMisc.undef"):_] // skip functions which are undefined
						= lmap				
					[TAssignmentOp: ts]
						= put name (LT_FUNC line (DT_NEED_PROCESS ts)) lmap
					[TCAFAssignmentOp: ts]
						= put name (LT_FUNC line (DT_NEED_PROCESS ts)) lmap						
					[TMacroAssignmentOp: ts]
						= put name (LT_MACRO (macroBody ts) (DT_NEED_PROCESS ts)) lmap						
						= lmap // something wrong with this line: skip it
				= (lmap, if (isNothing startfn && endsWith ".Start" name) (Just name) startfn, id+1)
									   
			_	= (lmap, startfn, id+1) // skip line. e.g. comment
where 
	skip_to_definition [TIdentifier _:ts] = skip_to_definition ts
	skip_to_definition [TStrictIdentifier _:ts] = skip_to_definition ts
	skip_to_definition [TTypeDef:ts] = skip_to_definition ts
	skip_to_definition ts = ts
	
	macroBody ts = toString (macroBody_ (filter macroTokens ts) newAppender)
	where
		macroBody_ [t] a = a <++ toString t		
		macroBody_ [t:ts] a = a <++ toString t <++ " "		
		macroBody_ [] a = a
		
	macroTokens (TComment _) = False
	macroTokens TEndOfLine = False	
	macroTokens _ = True	
	
// Get contructor names from ADT definition
parse_ADT [(TIdentifier name):ts] fn lmap
	= parse_ADT (skip_to_next_const ts) fn (put name (LT_REDIRECT fn) lmap)
where 
	skip_to_next_const [TVerticalBar:ts] = ts
	skip_to_next_const [_:ts] = skip_to_next_const ts
	skip_to_next_const [] = []	

// This is an incorrect line: skip it
parse_ADT [_:ts] _ lmap
	= lmap

parse_ADT [] _ lmap = lmap

// Get contructor names from record definition
parse_record [TIdentifier name:ts] fn lmap
	= parse_record ts fn (put name (LT_REDIRECT fn) lmap)

// Skip everything else (should be ",")
parse_record [_:ts] fn lmap 
	= parse_record ts fn lmap
	
parse_record [] _ lmap = lmap

generate_source :: !FuncTypeMap !(Loader st) !String !*World !StringAppender -> *(!FuncTypeMap, !(Loader st), !*World, !StringAppender)
generate_source llmap loader=:(lf,ls) fn world a 
	# (line, llmap, ls, world) = lf ls fn llmap world
	= generate_source_ llmap (lf,ls) fn line world a
where 
	generate_source_ lmap loader fn (Just (LT_REDIRECT name)) world a
		# lmap = del fn lmap // safe to delete because redirect can't link to macro

		// redirect always redirects to the same module, so it is safe to not
		// to try to load the module
		= generate_source_ lmap loader name (get name lmap) world a

	generate_source_ lmap (lf,ls) fn (Just (LT_FUNC line dt)) world a
		# lmap = del fn lmap
		# deps = gendep fn dt
		# (lmap, (lf,ls), world, a) = substitute_macros lmap deps (lf,ls) line world a
						  
		= foldl (\(lmap, loader, world, a) t = generate_source lmap loader t world a) 
															(lmap, (lf,ls), world, a) deps
	
	// don't delete macros
	// do nothing, macros are substituted
	generate_source_ lmap loader fn (Just (LT_MACRO _ DT_NO_DEPENDENCY)) world a
		= (lmap, loader, world, a) 

	// process macro dependencies only once
	generate_source_ lmap loader fn (Just (LT_MACRO body dt)) world a
		# deps = gendep fn dt
		// macro can't have macro dependency. by design.
		# (lmap, loader, world, a) = foldl (\(lmap, loader, world, a) t = generate_source lmap loader t world a) 
										   (lmap, loader, world, a) deps
		= (put fn (LT_MACRO body DT_NO_DEPENDENCY) lmap, loader, world, a)		
			
	// try to load the module								
	generate_source_ lmap loader fn Nothing world a
		= (lmap, loader, world, a) 

	gendep fn DT_NO_DEPENDENCY = []
	// Remove cyclyc and duplicate dependencies
	gendep fn (DT_NEED_PROCESS ts) = removeMember fn (removeDup (generate_dependencies ts []))

// [String] : dependencies
load_dependencies :: !FuncTypeMap ![String] ![(String,Maybe LineType)] !(Loader st) *World -> (!FuncTypeMap, ![(String, Maybe LineType)], !(Loader st), !*World)
load_dependencies lmap [m:ms] mlines (lf,ls) world
	# (line, lmap, ls, world) = lf ls m lmap world 
	= load_dependencies lmap ms [(m,line):mlines] (lf,ls) world

load_dependencies lmap [] mlines loader world
	= (lmap, mlines, loader, world)

substitute_macros :: !FuncTypeMap ![String] !(Loader st) !String !*World !StringAppender -> (!FuncTypeMap, !(Loader st), !*World, StringAppender)
substitute_macros lmap deps loader line world a

		// deps: [name], depbodies: [(name, line)]
		# (lmap, depbodies, loader, world) = load_dependencies lmap deps [] loader world
		# macros = map (\(name, Just (LT_MACRO body _))=(name, body)) (filter is_macro depbodies)

		# a = case isEmpty macros of
					True = a <++ line
						 = substitute_macros_ line macros 0 0 a

		= (lmap, loader, world, a)
	where
		substitute_macros_ line macros base last a
			| base < (size line)
				# (start, newbase, t) = read_token base line
				= case t of
					(TIdentifier name) = case trythem name macros of
											Just body # a = a <++ line % (last, start-1) <++ body
													  =	substitute_macros_ line macros newbase newbase a
													  = substitute_macros_ line macros newbase last a
									   = substitute_macros_ line macros newbase last a
				= a <++ line % (last, size line)
				
		trythem what [(macroname, body): ms]
			| what == macroname 
				= Just body
				= trythem what ms

		trythem _ [] = Nothing

		is_macro (_,(Just (LT_MACRO _ _))) = True
		is_macro _ = False	

sapl_module_name_extension :: String
sapl_module_name_extension = "sapl"
sapl_program_name_extension :: String
sapl_program_name_extension = "sapl"					 
					 	
detect_module_name :: !String !*World -> (Bool, Maybe String, !*World)
detect_module_name filename world
	# (ok, mbLine, world) = readLine filename world
	| not ok
		= (False, Nothing, world)
	    = (True, (detect o tokens o fromJust) mbLine, world)
where
	detect [TComment str:_]
		= case matchAt "?module?" str start1 of
			False = Nothing
		    True  # start2 = skipChars str (start1 + 8) isSpace
				  # end2   = skipChars str start2 (not o isSpace)
				  = Just (str % (start2, end2 - 1))
		where start1 = skipChars str 0 (\c -> not (c == '?'))
	detect _ = Nothing
	
built_in_modules :: !String !*World -> (Bool, [String], !*World)					 
built_in_modules dir world
	# ((ok, path), world) = pd_StringToPath dir world
	| ok
		# ((_, entries), world) = getDirectoryContents path world
		= (True, map full_path (filter filter_modules entries), world)
		= (False, [], world)
where
	// filter out dependecy files and subdirectories 
	filter_modules entry = not (entry.fileInfo.pi_fileInfo.isDirectory || ((ext entry.fileName) <> sapl_module_name_extension))
	full_path entry = dir +++ {path_separator} +++ entry.fileName
	ext f = snd (extractPathFileAndExtension f)