implementation module iTasks.Gin.Compiler import StdFile, StdMisc import iTasks import iTasks.Framework.IWorld import iTasks.Gin.Syntax import iTasks.Gin.AbstractSyntax import iTasks.Gin.Parser import iTasks.Gin.CompilerLogParser import iTasks.Gin.Config import Text import Data.Error import System.OSError import System.FilePath from System.File import instance toString FileError, readFile, writeFile from System.Process import qualified callProcess from Data.Map import newMap //from PmCleanSystem import //::CompileOrCheckSyntax(..), //::CodeGenerateAsmOrCode(..), //::CompilerMsg(..), //::CompilerOptions(..), //::CompilerProcess, //::CompilingInfo, //::List, //::ListTypes(..), //::LogEnv(..), //::Pathname, //::WindowFun, //CodeGen, //CompilePersistent, //DefaultCompilerOptions, //ExitCleanCompiler, //InitCompilingInfo, //Link, //instance == CompilerMsg //from PmPath import //MakeABCSystemPathname, //MakeObjSystemPathname //from PmTypes import //:: ApplicationOptions(..), //:: CodeGenOptions(..), //:: Output(..), //:: Processor, //DefApplicationOptions, //DefaultProcessor, //DefCodeGenOptions from linkargs import :: LinkInfo`(..), :: LPathname, ReadLinkOpts import UtilStrictLists from System.File import deleteFile derive class iTask CompileResult //derive JSONEncode CompilingInfo, CompilerProcess //derive JSONDecode CompilingInfo, CompilerProcess tmpDirectory :: *IWorld -> String tmpDirectory iworld=:{dataDirectory} = dataDirectory +++ "-gin-temp" runCompiler :: !GModule !(AModule -> (String, FunctionMap, LineMap)) (String String GinConfig FunctionMap LineMap *IWorld -> (CompileResult a, *IWorld)) *IWorld -> (CompileResult a, *IWorld) runCompiler gMod printfun compiler iworld = undef // TODO ////1. Load configuration //# (config,iworld) = accWorldIWorld ginLoadConfig iworld //| isNothing config = (CompileGlobalError "Configuration not found", iworld) //# config = fromJust config ////2. Parse and transform GModule //# (st, iworld) = accWorldIWorld (gToAModule gMod config) iworld //# result = runParse st //| isParseError result = (CompilePathError (getParseError result), iworld) //# aMod = expandModule (getParseSuccess result) ////3. (Pretty-)print module //# (basename,iworld) = getUniqueBasename iworld //# (source,functionMap,lineMap) = printfun { AModule | aMod & name = basename } ////4. Write source code to temp icl file //# fullname = (filenameFromConfig config (tmpDirectory iworld) basename "icl") //# (result, iworld) = accWorldIWorld (writeFile fullname source) iworld //| isError result = (CompileGlobalError ("Write icl file failed: " +++ toString (fromError result)), iworld) ////5. Call compiler function //# (result, iworld) = compiler source basename config functionMap lineMap iworld ////6. Delete temp icl file //# (deleted,iworld) = accWorldIWorld (deleteFile fullname) iworld //| isError deleted = (CompileGlobalError ("Failed to delete file " +++ fullname +++ ": " +++ snd (fromError deleted)), iworld) //= (result, iworld) getUniqueBasename :: *IWorld -> (String, *IWorld) getUniqueBasename iworld = undef // TODO //# (mCounter, iworld) = loadValue key iworld //# counter = case mCounter of //Just c = c + 1 //Nothing = 0 //# iworld = storeValue key counter iworld //= (prefix +++ (toString counter), iworld) //where //key = "gin-tempfile" //prefix = "temp" batchBuild :: !GModule *IWorld -> (CompileResult String, *IWorld) batchBuild gMod iworld = runCompiler gMod printfun build iworld where printfun :: AModule -> (String, FunctionMap, LineMap) printfun aMod = (prettyPrintAModule POWriteDynamics aMod, newMap, newMap) build :: !String !String !GinConfig FunctionMap LineMap *IWorld -> (CompileResult String, *IWorld) build source basename config functionMap lineMap iworld = undef // TODO //# (res, iworld) = accWorldIWorld (readFile (config.iTasksPath "Server" "Gin" "project-template")) iworld //| isError res = (CompileGlobalError ("Failed to read project template file: " +++ toString (fromError res)), iworld) //# projectFile = replaceSubString "{UserPath}" config.userPath (replaceSubString "{Basename}" basename (fromOk res)) //# (res, iworld) = accWorldIWorld (writeFile (filenameFromConfig config (tmpDirectory iworld) basename "prj") projectFile) iworld //| isError res = (CompileGlobalError ("Failed to write project file: " +++ toString (fromError res)), iworld) //# projectFile = filenameFromConfig config (tmpDirectory iworld) basename "prj" //# (res, iworld) = accWorldIWorld ('System.Process'.callProcess (config.cleanPath "CleanIDE.exe") ["--batch-build", projectFile] (Just config.cleanPath)) iworld //# (deleted,iworld) = accWorldIWorld (deleteFile projectFile) iworld //| isError deleted = (CompileGlobalError ("Failed to delete file " +++ projectFile +++ ": " +++ snd (fromError deleted)), iworld) //| isError res = (CompileGlobalError ("Calling Clean IDE failed: " +++ snd (fromError res)), iworld) //| fromOk res == 0 //# batchfile = (filenameFromConfig config (tmpDirectory iworld) basename "bat") //# (res, iworld) = accWorldIWorld ('System.Process'.callProcess batchfile [] Nothing) iworld //| isError res = (CompileGlobalError ("Failed to run dynamic linker batch file: " +++ snd (fromError res)), iworld) //# dynfile = filenameFromConfig config (tmpDirectory iworld) basename "dyn" //= (CompileSuccess dynfile, iworld) //# (res, iworld) = accWorldIWorld (readFile (filenameFromConfig config (tmpDirectory iworld) basename "log")) iworld //| isError res = (CompileGlobalError ("Read log file failed: " +++ toString (fromError res)), iworld) //# log = fromOk res //= (CompileGlobalError log, iworld) syntaxCheck :: !GModule *IWorld -> (CompileResult Void, *IWorld) syntaxCheck gMod iworld = undef // runCompiler gMod syntaxCheckPrintAModule (compile SyntaxCheck) iworld // -------------------------------------------------------------------------------- // Compiler interface // -------------------------------------------------------------------------------- //compile :: CompileOrCheckSyntax !String !String !GinConfig FunctionMap LineMap *IWorld -> (CompileResult Void, *IWorld) compile compileOrCheckSyntax source basename config functionMap lineMap iworld = undef // TODO //# (mCompilingInfo, iworld) = loadCompilingInfo iworld //# compilingInfo = case mCompilingInfo of //Just c = c //Nothing = InitCompilingInfo //# ((compileResult, compilingInfo), iworld) = accWorldIWorld (compile` compilingInfo) iworld //# iworld = storeCompilingInfo compilingInfo iworld //# iworld = exitCompiler iworld //<- TODO: remove //= (compileResult, iworld) //where //compile` :: CompilingInfo *World -> ((CompileResult Void, CompilingInfo), *World) //compile` compilingInfo world ////Take iTasks compiler if iTasks is in subdirectory of Clean distribution ////Otherwise, fallback to compiler shipped with Clean distribution //# compilerPath = //if (config.GinConfig.cleanPath "" == takeDirectory config.GinConfig.iTasksPath "") //(dropDirectory config.GinConfig.iTasksPath "Compiler") //("Tools" "Clean System") //# env = { LogEnv | errors = [], world = world } //# compilingInfo = InitCompilingInfo //<- TODO: remove //# (compilingInfo, (env, _, compilerMsg)) = //CompilePersistent //(compilerPath "CleanCompiler.exe" +++ " : -h 64M -dynamics -generics") //False //Don't write module times //addError //Error display function //(\_ x -> x) //Types display function //compileOrCheckSyntax //(basename +++ ".icl") //(ListToStrictList (searchPaths config (tmpDirectory iworld))) //False //No memory profiling //False //No time profiling //True //Eager or dynamic linking //{ DefaultCompilerOptions & listTypes = NoTypes } //config.cleanPath //compilingInfo //env //# log = join "\n" (map (join "\n") env.LogEnv.errors) //| compilerMsg == GlobalError //= ((CompileGlobalError ("Calling Clean compiler failed: " +++ log), compilingInfo), env.LogEnv.world) //| compilerMsg == CompilerOK //= ((CompileSuccess Void, compilingInfo), env.LogEnv.world) //# errors = (findPathErrors (parseCleanCompilerLog log) functionMap lineMap) //| isEmpty errors = ((CompileGlobalError log, compilingInfo), env.LogEnv.world) //= ((CompilePathError errors, compilingInfo), env.LogEnv.world) //loadCompilingInfo :: *IWorld -> (Maybe CompilingInfo, *IWorld) loadCompilingInfo iworld = undef // TODO loadValue compilerId iworld //storeCompilingInfo :: CompilingInfo *IWorld -> *IWorld storeCompilingInfo compilingInfo iworld = undef // TODO storeValue compilerId compilingInfo iworld compilerId :: String compilerId = "gin-compiler" deleteCompilingInfo :: *IWorld -> *IWorld deleteCompilingInfo iworld = undef // TODO deleteValue compilerId iworld exitCompiler :: *IWorld -> *IWorld exitCompiler iworld = undef //# (mCompilingInfo, iworld) = loadCompilingInfo iworld //| isNothing mCompilingInfo = iworld //# compilingInfo = fromJust mCompilingInfo //# (_, iworld) = accWorldIWorld (curry ExitCleanCompiler (fromJust mCompilingInfo)) iworld //= deleteCompilingInfo iworld /* // -------------------------------------------------------------------------------- // Code generator interface // -------------------------------------------------------------------------------- codegen :: !String !GinConfig *IWorld -> (CompileResult Void, *IWorld) codegen basename config iworld=:{tmpDirectory} = accWorldIWorld codegen` iworld where codegen` :: !*World -> (CompileResult Void, *World) codegen` world # env = { errors = [], world = world } # abcfile = MakeABCSystemPathname (filenameFromConfig config tmpDirectory basename "icl") # (pathname, ok, env) = CodeGen ("Tools" "Clean System" "CodeGenerator.exe") addError CodeGeneration abcfile False //No time profiling DefCodeGenOptions DefaultProcessor ginApplicationOptions config.cleanPath env # log = join "\n" (map (join "\n") env.LogEnv.errors) | not ok = (CompileGlobalError ("Code generator error: " +++ log), env.LogEnv.world) # world = env.LogEnv.world # (_,world) = deleteFile abcfile world = (CompileSuccess Void, world) // -------------------------------------------------------------------------------- // Linker interface // -------------------------------------------------------------------------------- link :: String !GinConfig *IWorld -> (CompileResult Void, *IWorld) link basename config iworld=:{tmpDirectory} = accWorldIWorld (link` basename config) iworld where link` :: !String !GinConfig *World -> (CompileResult Void, *World) link` basename config world # ((linkinfo, ok, err), world) = accFiles (ReadLinkOpts (config.iTasksPath "Server" "Gin" "linkopts-template")) world | not ok = (CompileGlobalError ("Linker error: Failed to read linker options file: " +++ err), world) # env = { errors = [], world = world } # linkopts = MakeObjSystemPathname DefaultProcessor (filenameFromConfig config tmpDirectory (basename +++ "_options") "icl") # (env, ok) = Link ("Tools" "Clean System" "StaticLinker.exe") addError (filenameFromConfig config tmpDirectory basename "exe") ginApplicationOptions linkopts // linker obtions file (dynamicLibs config tmpDirectory basename linkinfo) // dynamic library file names (objectPaths config tmpDirectory basename linkinfo) // object file names Nil // static library file names False // link statically False // generate relocations False // generate link map False // link in resources "" // source of resources to link in False // generate dll? "" // dll export symbols config.cleanPath // startup directory ("Tools" "Dynamics" "DynamicLinker.exe") DefaultProcessor False // 64 bit target processor env //Delete object file and link opts # world = env.LogEnv.world # (_, world) = deleteFile (MakeObjSystemPathname DefaultProcessor (filenameFromConfig config tmpDirectory basename "obj")) world # (_, world) = deleteFile linkopts world # log = join "\n" (map (join "\n") env.LogEnv.errors) | not ok = (CompileGlobalError (log), world) = (CompileSuccess Void, world) dynamicLibs :: !GinConfig !String !String !LinkInfo` -> List LPathname dynamicLibs config tempPath basename linkinfo = Map (setLinkPaths config tempPath basename) linkinfo.dynamic_libs objectPaths :: !GinConfig !String !String !LinkInfo` -> List LPathname objectPaths config tempPath basename linkinfo = Map (setLinkPaths config tempPath basename) linkinfo.object_paths setLinkPaths :: !GinConfig !String String !String -> String setLinkPaths config tempPath basename haystack # haystack = replaceSubString "{Project}" tempPath haystack # haystack = replaceSubString "{ITasks}" config.iTasksPath haystack # haystack = replaceSubString "{Application}" config.cleanPath haystack # haystack = replaceSubString "{Serialization}" serializationModule haystack = replaceSubString "{Basename}" basename haystack */ // -------------------------------------------------------------------------------- // Utility functions // -------------------------------------------------------------------------------- failed :: (CompileResult a) -> Bool failed (CompileSuccess _) = False failed _ = True convertFail :: (CompileResult a) -> (CompileResult b) convertFail (CompileGlobalError msg) = CompileGlobalError msg convertFail (CompilePathError paths) = CompilePathError paths //addError :: [String] LogEnv -> LogEnv addError err _ = undef //{LogEnv | errors=errs, world=w } = {LogEnv | errors = errs ++ [err], world=w} /* trace_n (join "\n" err) */ accWorldIWorld :: (*World -> (b, *World)) *IWorld -> (b, *IWorld) accWorldIWorld f iworld # (r, world) = f iworld.IWorld.world = (r, { IWorld | iworld & world = world }) appWorldIWorld :: (*World -> *World) *IWorld -> *IWorld appWorldIWorld f iworld = { IWorld | iworld & world = f iworld.IWorld.world } filenameFromConfig :: !GinConfig !String !String !String -> String filenameFromConfig config tempPath basename extension = tempPath basename +++ "." +++ extension // -------------------------------------------------------------------------------- // Project settings // -------------------------------------------------------------------------------- //ginApplicationOptions :: ApplicationOptions ginApplicationOptions = undef // { DefApplicationOptions & o = NoConsole} searchPaths :: !GinConfig !String -> [String] searchPaths config tempPath = [ tempPath : config.userPath : map (() config.iTasksPath) iTasksPaths ++ map (() config.cleanPath) cleanPaths ] iTasksPaths :: [String] iTasksPaths = [ "Server" , "Server\\API\\Common" , "Server\\API\\Core" , "Server\\API\\Extensions" , "Server\\API\\Extensions\\Admin" , "Server\\Framework" , "Server\\Framework\\Data" , "Server\\Framework\\Handlers" , "Server\\lib" , "Server\\lib\\Http" , "Server\\lib\\Platform\\OS-Independent" , "Server\\lib\\Platform\\OS-Independent\\Data" , "Server\\lib\\Platform\\OS-Independent\\Database" , "Server\\lib\\Platform\\OS-Independent\\Database\\SQL" , "Server\\lib\\Platform\\OS-Independent\\GUI" , "Server\\lib\\Platform\\OS-Independent\\Internet" , "Server\\lib\\Platform\\OS-Independent\\Internet\\HTTP" , "Server\\lib\\Platform\\OS-Independent\\Math" , "Server\\lib\\Platform\\OS-Independent\\Network" , "Server\\lib\\Platform\\OS-Independent\\System" , "Server\\lib\\Platform\\OS-Independent\\Test" , "Server\\lib\\Platform\\OS-Independent\\Text" , "Server\\lib\\Platform\\OS-Independent\\Text\\Encodings" , "Server\\lib\\Platform\\OS-Windows\\Data" , "Server\\lib\\Platform\\OS-Windows\\Network" , "Server\\lib\\Platform\\OS-Windows\\System" , "Server\\lib\\Platform\\OS-Windows\\Database" , "Server\\lib\\Platform\\OS-Windows\\Database\\SQL" , "Server\\lib\\Platform\\OS-Windows-32\\System" , "Server\\lib\\graph_copy" ] cleanPaths :: [String] cleanPaths = [ "Libraries\\StdEnv" , "Libraries\\StdLib" , "Libraries\\Generics" , "Libraries\\Dynamics" , "Libraries\\Dynamics\\general" , "Libraries\\Dynamics\\implementation" , "Libraries\\Dynamics\\implementation\\windows" , "Libraries\\Directory" , "Libraries\\TCPIP" ]