implementation module GinCompiler import StdFile import iTasks import IWorld import GinSyntax import GinAbstractSyntax import GinParser import GinCompilerLogParser import GinConfig import Text import Error import OSError import FilePath from File import instance toString FileError, readFile, writeFile from Process import qualified callProcess from 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 File import deleteFile derive class iTask CompileResult derive JSONEncode CompilingInfo, CompilerProcess derive JSONDecode CompilingInfo, CompilerProcess runCompiler :: !GModule !(AModule -> (String, FunctionMap, LineMap)) (String String GinConfig FunctionMap LineMap *IWorld -> (CompileResult a, *IWorld)) *IWorld -> (CompileResult a, *IWorld) runCompiler gMod printfun compiler iworld=:{tmpDirectory} //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 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 # (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=:{tmpDirectory} = 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 # (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 basename "prj") projectFile) iworld | isError res = (CompileGlobalError ("Failed to write project file: " +++ toString (fromError res)), iworld) # projectFile = filenameFromConfig config tmpDirectory basename "prj" # (res, iworld) = accWorldIWorld ('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 basename "bat") # (res, iworld) = accWorldIWorld ('Process'.callProcess batchfile [] Nothing) iworld | isError res = (CompileGlobalError ("Failed to run dynamic linker batch file: " +++ snd (fromError res)), iworld) # dynfile = filenameFromConfig config tmpDirectory basename "dyn" = (CompileSuccess dynfile, iworld) # (res, iworld) = accWorldIWorld (readFile (filenameFromConfig config tmpDirectory 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 = 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=:{tmpDirectory} # (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 = { 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)) 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 = loadValue compilerId iworld storeCompilingInfo :: CompilingInfo *IWorld -> *IWorld storeCompilingInfo compilingInfo iworld = storeValue compilerId compilingInfo iworld compilerId :: String compilerId = "gin-compiler" deleteCompilingInfo :: *IWorld -> *IWorld deleteCompilingInfo iworld = deleteValue compilerId iworld exitCompiler :: *IWorld -> *IWorld exitCompiler iworld # (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 env = /* trace_n (join "\n" err) */ { env & errors = env.errors ++ [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 = { 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" ]