implementation module iTasks.Gin.DCLImport

import StdEnv

from System.File import deleteFile
from System.FilePath import dropDirectory, dropExtension, :: FilePath
from Data.Error import Error, Ok
from System.OSError import :: MaybeOSError, :: OSError, :: OSErrorMessage, :: OSErrorCode, :: MaybeError, :: MaybeErrorString

import Data.Maybe

from CleanDocParser import parseModule, parseFunctionComment, emptyFunctionComment, :: FunctionComment (..), :: ParamComment (..)

import iTasks.Gin.Syntax

from general 	import 	::Optional(..)
from Heap 		import 	::Ptr

from scanner	import
						::Assoc(..),
						::Priority(..)
from syntax		import	
						::AttributeVar, 
						::AttrInequality, 
						::AType(..), 
						::ATypeVar,
						::BasicType,
						::ClassDef,
						::ConsVariable,
						::DefinedSymbol,
						::FunKind,
						::FunSpecials,
						::GenericCaseDef,
						::GenericDef,
						::Global,
						::GlobalIndex,
						::Ident(..), 
						::Import,
						::ImportedObject,
						::Index,
						::ParsedDefinition(..),
						::ParsedExpr,
						::ParsedImport,
						::ParsedInstanceAndMembers,
						::ParsedTypeDef,
						::Position,
						::Rhs,
						::RhsDefsOfType,
						::StrictnessList, 
						::SymbolPtr,
						::SymbolTableEntry,
						::SymbolType(..), 
						::TempVarId,
						::Type(..),
						::TypeAttribute(..),
						::TypeContext, 
						::TypeDef,
						::TypeKind,
						::TypeSymbIdent(..),
						::TypeSymbProperties,
						::TypeVar(..),
						::TypeVarInfo,
						::TypeVarInfoPtr,
						instance toString BasicType

importDCL :: !String !String *World -> (MaybeErrorString GModule, *World)
importDCL filename source world
# errorFilename 		= "errors"
# (ok,errorFile,world) 	= fopen errorFilename FWriteText world
| not ok 				= (Error "Failed to open errors file", world)
# (defs, errorFile) 	= parseModule source False errorFile
# (ok,world)			= fclose errorFile world
| not ok 				= (Error "Failed to close errors file", world)
# (ok, world)			= deleteFile errorFilename world

# gMod 					= mapModule (dropExtension (dropDirectory filename)) defs
= (Ok gMod, world)

mapModule :: !String [ParsedDefinition] -> GModule
mapModule name defs =
	{ GModule
	| name = name
	, types = []
	, moduleKind = GCleanModule (mapDefinitions defs)
	, imports = []
	}

mapDefinitions :: [ParsedDefinition] -> [Binding]
mapDefinitions [] = []
mapDefinitions [PD_Documentation docstr: PD_TypeSpec pos ident prio optSymbtype specials: defs]
	# res = parseFunctionComment docstr
	# doc = case res of
		Ok doc = doc
		Error err = emptyFunctionComment
	= case mapFunction doc ident prio optSymbtype of
		Just binding = [binding:mapDefinitions defs]
		Nothing = mapDefinitions defs
mapDefinitions [def:defs] = mapDefinitions defs

mapFunction :: !FunctionComment Ident Priority (Optional SymbolType) -> Maybe Binding
mapFunction _ _	_ No       = Nothing
mapFunction _ _ _ (Yes st) | not (isTask (mapAType st.st_result)) = Nothing
mapFunction doc _ _ _
	| not doc.FunctionComment.gin = Nothing
mapFunction doc ident prio (Yes st) 
	| doc.FunctionComment.parallel && isJust doc.FunctionComment.title && isJust doc.FunctionComment.icon
	= Just	( ParallelBinding	{ split =	{ GDeclaration
											| name = "_split"
											, title = Just "Parallel split"
											, description = Just "Splits a parallel branch into multiple concurrent branches"
											, formalParams = []
											, returnType = GUndefinedTypeExpression
											, returnDescription = Nothing
											, icon = Just "parallel-split"
											, shape = GDefaultShape
											}
								, merge =	{ GDeclaration
											| name = ident.id_name
											, title = doc.FunctionComment.title
											, description = doc.FunctionComment.description
											, formalParams = []
											, returnType = GUndefinedTypeExpression
											, returnDescription = Nothing
											, icon = doc.FunctionComment.icon
											, shape = GDefaultShape
											}
								, type = mapAType st.st_result
								, fixedNrBranches = case prio of
									NoPrio   = Nothing
									Prio _ _ = Just 2
								, parameterMap = case prio of
									NoPrio         = App [Var ident.id_name,Extension PBBranchList]
									Prio assoc pri = AppInfix ident.id_name (mapAssoc assoc) pri (Extension (PBBranch 0)) (Extension (PBBranch 1))
								}
			)

mapFunction doc ident prio (Yes st)
	| not doc.FunctionComment.parallel
	= (Just	( NodeBinding	
				{ NodeBinding 
				| declaration = 
					{ GDeclaration
					| name = ident.id_name
					, title = doc.FunctionComment.title
					, description = doc.FunctionComment.description
					, formalParams = if (length doc.FunctionComment.params == length st.st_args)
						[ mapFormalParameter d p \\ d <- doc.FunctionComment.params & p <- st.st_args ]
						[ mapFormalParameter	{ ParamComment
												| name = "param" +++ toString i
												, title = Just (toString (mapAType p))
												, description = Nothing 
												, defaultValue = Nothing
												, visible = True
												} 
												p 
						  \\ p <- st.st_args & i <- [1..] ]
					, returnType = mapAType st.st_result
					, returnDescription = doc.FunctionComment.return
					, icon = doc.FunctionComment.icon
					, shape = case doc.FunctionComment.shape of
						Just filename	= GExternalShape filename
						Nothing 		= GDefaultShape 
					}				
				, parameterMap = case prio of
					NoPrio = NBPrefixApp
					Prio assoc pri = NBInfixApp (mapAssoc assoc) pri
				}
			)
		)

mapFunction _ _ _ _ = Nothing

mapAssoc :: Assoc -> AFix
mapAssoc LeftAssoc  = Infixl
mapAssoc RightAssoc = Infixr
mapAssoc NoAssoc    = Infix

mapFormalParameter :: !ParamComment AType -> GFormalParameter
mapFormalParameter doc type = 
	{ GFormalParameter
	| name			= doc.ParamComment.name
	, title			= doc.ParamComment.title
	, description 	= doc.ParamComment.description
	, type			= mapAType type
	, defaultValue	= doc.ParamComment.defaultValue
	, visible		= doc.ParamComment.visible
	}

mapAType :: AType -> GTypeExpression
mapAType atype = mapType atype.at_type

mapType :: Type -> GTypeExpression
mapType (TA ident [])  = GConstructor (ident.type_ident.id_name)
mapType (TA ident [param]) 
	| ident.type_ident.id_name == "_List" = GList (mapAType param)
mapType (TA ident params) = GTypeApplication [GConstructor ident.type_ident.id_name : map mapAType params]
mapType (TAS ident [] _)  = GConstructor (ident.type_ident.id_name)
mapType (TAS ident params _)  = GTypeApplication [GConstructor ident.type_ident.id_name : map mapAType params]
mapType (TV tv) = GTypeVariable (tv.tv_ident.id_name)
mapType (--> a b) = GFunction (mapAType a) (mapAType b)
mapType (TB bt) = GConstructor (toString bt)
mapType _ = GTypeVariable "(Unknown type)"