implementation module iTasks.Gin.AbstractSyntax

import StdBool
from StdFunc import o
import StdOrdList
import StdList
import StdString
import StdClass, StdInt

import Data.Void
import Data.Map
import Text
import Data.Maybe

from iTasks.Gin.Parser import :: GPath(..), :: GTypeDefinition(..), :: GTypeExpression(..), :: GFormalParameter(..), :: GIdentifier(..), :: GTypeVariable(..), :: GTypeRhs(..), :: GRecordField(..), :: GDataConstructor(..)
from iTasks.Gin.Types import generic gEq, generic JSONDecode, generic JSONEncode, generic gVerify, generic gUpdate, generic gDefault, generic gGridRows, generic gHeaders, generic gVisualizeText, generic gVisualizeEditor
from iTasks.Gin.Types import :: JSONNode, :: InteractionMask, :: VerifyMask, :: VerifyOptions, :: ConsPos, :: StaticVisualizationMode, :: VSt, :: VisualizationResult
from iTasks.Gin.Types import printGTypeDefinition, typeIsDefined, printGTypeExpression
import iTasks.Gin.Printer

from GenEq import ===

from iTasks.Framework.iTaskClass import class iTask, gEq

derive class iTask AModule, ADefinition, AExpression, ACaseAlt, AListComprehension, AGeneratorList, AGenerator, AFix

instance == AFix
where
	(==) Infixl Infixl = True
	(==) Infix  Infix  = True
	(==) Infixr Infixr = True
	(==) _      _      = False

expandModule :: AModule -> AModule
expandModule aMod 
= { AModule | aMod & definitions = flatten (map expandDefinition aMod.AModule.definitions) }

expandDefinition :: ADefinition -> [ADefinition]
expandDefinition aDef =: { ADefinition | formalParams, body }
# scope = [p.GFormalParameter.name \\ p <- formalParams]
#(accLocals, body) = case body of
                         PathContext path exp = let (accLocals, body) = expandExpression scope [] exp
                                                in (accLocals, PathContext path body)
                         otherwise            = expandExpression scope [] body
= [{ ADefinition | aDef & body = body, locals = flatten (map expandDefinition aDef.ADefinition.locals) }
   : reverse accLocals
  ]

expandExpression :: Scope Locals (AExpression Void)  -> (Locals, AExpression Void)
expandExpression scope accLocals (Unparsed s) = (accLocals, Unparsed s)
expandExpression scope accLocals (Lit s) = (accLocals, Lit s)
expandExpression scope accLocals (Var v) = (accLocals, Var v)
expandExpression scope accLocals (App exps)
	# (accLocals, exps`) = expandMap scope accLocals expandExpression exps
	= (accLocals, App exps`)
expandExpression scope accLocals (AppInfix i fix prec e1 e2)
	# (accLocals, e1`) = expandExpression scope accLocals e1
	# (accLocals, e2`) = expandExpression scope accLocals e2
	= (accLocals, AppInfix i fix prec e1` e2`)
expandExpression scope accLocals (Lambda pat exp) 
	# (accLocals, exp`) = expandExpression (bind pat scope) accLocals exp
	= (accLocals, Lambda pat exp`)
expandExpression scope accLocals (Let defs exp)
	# (accLocals, alts`) = expandMap scope accLocals expandLetDefs defs
	# (accLocals, exp`) = expandExpression scope accLocals exp
	= (accLocals, Let alts` exp`)
expandExpression scope accLocals (Case exp alts)
	# (accLocals, exp`) = expandExpression scope accLocals exp
	# (accLocals, alts`) = expandMap scope accLocals expandCaseAlt alts
	= (accLocals, Case exp` alts`)
expandExpression scope accLocals (Tuple exps)
	# (accLocals, exps`) = expandMap scope accLocals expandExpression exps
	= (accLocals, Tuple exps`)
expandExpression scope accLocals (List exps)
	# (accLocals, exps`) = expandMap scope accLocals expandExpression exps
	= (accLocals, List exps`)
expandExpression scope accLocals (ListComprehension alc)
	# (accLocals, alc`) = expandListComprehension scope accLocals alc
	= (accLocals, ListComprehension alc`)
expandExpression scope accLocals (PathContext path exp)
	# (accLocals, exp`) = expandExpression scope accLocals exp
	= makeLocal scope accLocals (PathContext path exp`)

expandLetDefs :: Scope Locals (APattern, AExpression Void) -> (Locals, (APattern, AExpression Void))
expandLetDefs scope accLocals (pat, exp) 
	# (accLocals, exp`) = expandExpression (bind pat scope) accLocals exp
	= (accLocals, (pat,exp`))

expandCaseAlt :: Scope Locals (ACaseAlt Void) -> (Locals, ACaseAlt Void)
expandCaseAlt scope accLocals (CaseAlt pat exp)
	# scope` = if (trim pat == "otherwise") scope (bind pat scope)
	# (accLocals, exp`) = expandExpression scope` accLocals exp
	= (accLocals, CaseAlt pat exp`)

expandListComprehension :: Scope Locals (AListComprehension Void) -> (Locals, (AListComprehension Void))
expandListComprehension scope accLocals { AListComprehension | output, generators, guards }
	# (accLocals, generators`, patterns) = expandGeneratorList scope accLocals generators
	# scope` = foldr bind scope patterns
	# (accLocals, guards`) = expandMap scope` accLocals expandExpression guards
	# (accLocals, output`) = expandExpression scope` accLocals output
	= (accLocals, { AListComprehension | output = output`, generators = generators`, guards = guards` })

expandGeneratorList :: Scope Locals (AGeneratorList Void) -> (Locals, AGeneratorList Void, [APattern])
expandGeneratorList scope accLocals (NestedGeneratorList generators)
	# (accLocals, generators`) = expandMap scope accLocals expandGenerator generators
	= (accLocals, NestedGeneratorList generators`, generatorPatterns generators)
expandGeneratorList scope accLocals (ParallelGeneratorList generators)
	# (accLocals, generators`) = expandMap scope accLocals expandGenerator generators
	= (accLocals, ParallelGeneratorList generators`, generatorPatterns generators)
	
generatorPatterns :: [AGenerator Void] -> [APattern]
generatorPatterns generators = map (\(Generator pat _) = pat) generators

expandGenerator :: Scope Locals (AGenerator Void) -> (Locals, AGenerator Void)
expandGenerator scope accLocals (Generator pat exp) 
	# (accLocals, exp`) = expandExpression scope accLocals exp
	= (accLocals, Generator pat exp`)

expandMap :: Scope Locals (Scope Locals a -> (Locals, b)) [a] -> (Locals, [b])
expandMap scope accLocals f []     = (accLocals, [])
expandMap scope accLocals f [x:xs]
	# (accLocals, x`) = f scope accLocals x
	# (accLocals, xs`) = expandMap scope accLocals f xs
	= (accLocals, [x`:xs`])

emptyVars :: Vars
emptyVars = []

addVar :: AIdentifier Vars -> Vars
addVar i vars = [i : filter (\p = p <> i) vars]

addVars :: [AIdentifier] Vars -> Vars
addVars is vars = foldr addVar vars is

mergeVars :: [Vars] -> Vars
mergeVars vs = foldr addVars emptyVars vs

inVars :: AIdentifier Vars -> Bool
inVars ident vars = isMember ident vars

makeLocal :: Scope Locals (AExpression Void) -> (Locals, (AExpression Void))
makeLocal scope accLocals exp
#var = freeVariable scope accLocals
#def = { ADefinition 
       | name = var
       , formalParams = reverse [	{ GFormalParameter 
       								| name = x 
       								, title = Nothing
       								, description = Nothing
       								, type = GUndefinedTypeExpression
       								, defaultValue = Nothing
       								, visible = True
       								} 
       								\\ x <- scope 
       							]
       , returnType = GUndefinedTypeExpression
       , body = exp
       , locals = []
       }
= ([def : accLocals], if (isEmpty scope) (Var var) (App [(Var var) : reverse (map Var scope)]))

/**
* Generate a new variable name which is free in Scope and Locals
*/
freeVariable :: Scope Locals -> AIdentifier
freeVariable scope locals = find 1
where
	find i  = let name = "v" +++ toString i 
	          in if (isMember name (scope ++ [ a.ADefinition.name \\ a <- locals ])) 
	                (find (inc i)) 
	                name

/**
* Pretty-printing of AModule's
*/


derive gEq PrintOption
instance == PrintOption where
	(==) a b = a === b

prettyPrintAModule :: PrintOption AModule -> String
prettyPrintAModule opt aMod = prettyPrint (printAModule opt aMod)

syntaxCheckPrintAModule :: AModule -> (String, FunctionMap, LineMap)
syntaxCheckPrintAModule aMod 
# aMod = expandModule aMod
# (source, lineMap) = positionPrint (printAModule POSyntaxCheck aMod)
= (source, makeFunctionMap aMod, lineMap)
where
	makeFunctionMap :: AModule -> FunctionMap
	makeFunctionMap {definitions} = fromList (flatten (map mkF definitions))
	where
		mkF :: ADefinition -> [(AIdentifier, GPath)]
		mkF { name, body = PathContext path _ , locals} = [(name, path)] ++ flatten (map mkF locals)
		mkF { locals } = flatten (map mkF locals)

printAModule :: PrintOption AModule -> a | Printer a
printAModule opt aMod =	
	scope (	[ printAModuleHeader opt aMod ]
			++ printAImports opt aMod.AModule.imports
			++ printATypes opt aMod.AModule.types
			++ printATypeDerives opt aMod.AModule.types
			++ flatten (map (printADefinition opt) aMod.AModule.definitions)
			++ printAStart opt aMod
		  )

printAModuleHeader :: PrintOption AModule -> a | Printer a
printAModuleHeader opt aMod = 
	def (	( case opt of
				PODCL = text "definition " 
				POICL = text "implementation "
				_	  = empty
			)
		  	<-> text "module" <+> text aMod.AModule.name
		)

printAImports :: PrintOption [AImport] -> [a] | Printer a
printAImports opt imports
	# standardImports = [ "StdInt"
						, "StdBool"
						, "StdString"
						, "StdList"
						, "StdOrdList"
						, "StdTuple"
						, "StdEnum"
						, "StdOverloaded"
						, "StdFile"
						]
						++
						( if (opt == POWriteDynamics) 
							["File", "Serialization"] 
							[]
						)
	//CoreCombinators is necessary for >>= and >>|, which do not require explicit imports in Gin
	=	[ def (text "import" <+> align (fillSep (punctuate comma [ text i \\ i <- standardImports ])))
		, def (text "import" <+> align (fillSep (punctuate comma [ text i \\ i <- removeDup (sort ["CoreCombinators" : imports])])))
		] 

printATypes :: PrintOption [GTypeDefinition] -> [a] | Printer a
printATypes opt _ | opt == POICL = []
printATypes opt types = map (printGTypeDefinition) types

printATypeDerives :: PrintOption [GTypeDefinition] -> [a] | Printer a
printATypeDerives opt types = flatten (map (printATypeDerive opt) types)

printATypeDerive :: PrintOption GTypeDefinition -> [a] | Printer a
printATypeDerive opt {name, rhs = GSynonymTypeRhs _} = []
printATypeDerive opt {name, rhs = GAbstractTypeRhs} = []
printATypeDerive opt {GTypeDefinition | name} = [text "derive class iTask" <+> text name]

printADefinition :: PrintOption ADefinition -> [a] | Printer a
printADefinition opt def =
	printADefinitionComment opt def
	++ printADefinitionType def
	++ printADefinitionBody opt def

printADefinitionComment :: PrintOption ADefinition -> [a] | Printer a
printADefinitionComment PODCL def =
	[	text "/**" <-$>
		text "*" <+> text def.ADefinition.name <-$>
		text "*" <-$>
		(if (isEmpty def.ADefinition.formalParams) 
			empty 
			( foldr (<-$>) empty (map (\fp -> text "* @param" <+> text fp.GFormalParameter.name) 
						def.ADefinition.formalParams
				   )
			)
		) <-$>
	//	text "* @return" <-$>
		text "*/"
	]
printADefinitionComment _ _ = []

printADefinitionType :: ADefinition -> [a] | Printer a
printADefinitionType { ADefinition | name, formalParams, returnType }
	| typeIsDefined returnType && 
	  and (map (\fp = typeIsDefined fp.GFormalParameter.type) formalParams)
	  = [	def ( text name
	    	  <+> text "::"
	    	  <-/> if (isEmpty formalParams)
	    	  	  empty
		          ( fillSep (map (\fp = printGTypeExpression True fp.GFormalParameter.type) formalParams) 
		            <-/> (text "->" <-/> space) <-/> empty
		          )
		      <-> printGTypeExpression False returnType
		    )
		]
	| otherwise 
	  = []

printADefinitionBody :: PrintOption ADefinition -> [a] | Printer a
printADefinitionBody PODCL _ = []
printADefinitionBody opt { ADefinition | name, formalParams, body, locals } = 
	[ def (	text name
			<+> if (isEmpty formalParams) empty 
			     (fillSep (map (\fp = text fp.GFormalParameter.name) formalParams) <-> space)
			<-> char '='
			<$?> printAExpression opt False body
		  )
	]
	++ if (isEmpty locals) 
			[]
			[ text "where"
			, newscope (flatten ((map (printADefinition opt) locals)))
			]
      
printAStart :: PrintOption AModule -> [a] | Printer a
printAStart POSyntaxCheck _ = 
	[ def (text "Start :: Int")
	, def (text "Start = 0")
	]
printAStart POWriteDynamics aMod
	# task = hd aMod.AModule.definitions
	=	[ def (text "Start :: *World -> *World")
	 	, def (text "Start world")
		, text "# (_, world) = writeFile" <-/> dquotes (text (aMod.AModule.name +++ ".dyn")) 
			<-/> parens (text "serialize" <-/> text (task.ADefinition.name))
			<-/> text "world"
		, text "= world"
		]
printAStart _ _ = []


printAExpression :: PrintOption Bool (AExpression Void) -> a | Printer a
printAExpression opt withParens (Unparsed s) = parens (string (replaceSubString "\n" " " (replaceSubString "\r" "" s)))
printAExpression opt withParens (Lit s) = text s
printAExpression opt withParens (Var v) = text v
printAExpression opt withParens (App exps) = addParens withParens (fillSep (map (printAExpression opt True) exps))
printAExpression opt withParens (AppInfix i fix prec e1 e2)
	# doc1 = case e1 of
		(AppInfix e1i e1fix e1prec _ _) = printAExpression opt (e1prec < prec || i == e1i && fix == Infixl) e1
		otherwise                       = printAExpression opt False e1
	# doc2 = case e2 of
		(AppInfix e2i e2fix e2prec _ _) = printAExpression opt (e2prec < prec || i == e2i && fix == Infixr) e2
		otherwise                       = printAExpression opt False e2
	= doc1 <-$> text i <-/> doc2
printAExpression opt withParens (Lambda pat exp)
	= addParens withParens (text "\\" <-> printAPattern opt pat <-/> text "->" <-/> printAExpression opt False exp)
printAExpression opt withParens (Let defs inexp) = addParens withParens (align (text "let" <+> 
	newscope (map (\(pat,exp) -> text pat <-/> text "=" <-/> align (printAExpression opt False exp)) defs) <-$>
	text "in" <-/> align (printAExpression opt False inexp)))
printAExpression opt withParens (Case exp alts) 
	= addParens withParens 
		(	align	(text "case" <-/> (printAExpression opt False exp) <-/> (text "of") <-$>
						newscope (map (\alt = printACaseAlt opt alt) alts)
					)
    	)
printAExpression opt withParens (Tuple exps) = parens (fillSep (punctuate comma (map (printAExpression opt False) exps)))
printAExpression opt withParens (List exps) = brackets (fillSep (punctuate comma (map (printAExpression opt False) exps)))
printAExpression opt withParens (ListComprehension alc) = printAListComprehension opt alc
printAExpression opt withParens (PathContext path exp) 
	| opt == POSyntaxCheck	= position path <-> printAExpression opt withParens exp
	| otherwise				= printAExpression opt withParens exp

addParens :: Bool a -> a | Printer a
addParens withParens a = if withParens (parens a) a

printAListComprehension  :: PrintOption (AListComprehension Void) -> a | Printer a
printAListComprehension opt alc = brackets
    ( (printAExpression opt False alc.AListComprehension.output) 
      <-/> text "\\\\" 
      <-/> printGeneratorList opt alc.AListComprehension.generators
      <-/> hsep (map (\guard -> text "|" <-/> printAExpression opt False guard) alc.AListComprehension.guards))
    
printGeneratorList :: PrintOption (AGeneratorList Void) -> a | Printer a
printGeneratorList opt (NestedGeneratorList generators) = fillSep (punctuate comma (map (printGenerator opt) generators))
printGeneratorList opt (ParallelGeneratorList generators) = fillSep (punctuate (text "&") (map (printGenerator opt) generators))

printGenerator :: PrintOption (AGenerator Void) -> a | Printer a
printGenerator opt (Generator sel exp) = printAPattern opt sel <-/> text "<-" <-/> printAExpression opt False exp

printACaseAlt :: PrintOption (ACaseAlt Void) -> a | Printer a
printACaseAlt opt (CaseAlt pat exp) = def (printAPattern opt pat <-/> text "=" <-/> align (printAExpression opt False exp))

printAPattern :: PrintOption APattern -> a | Printer a
printAPattern opt p = text p

printAIdentifier :: PrintOption AIdentifier -> a | Printer a
printAIdentifier opt i = text i

printComment :: PrintOption String -> a | Printer a
printComment opt s = text "/*" <-/> text s <-/> text "*/"