diff --git a/DDC/Driver/Build/Locate.hs b/DDC/Driver/Build/Locate.hs new file mode 100644 --- /dev/null +++ b/DDC/Driver/Build/Locate.hs @@ -0,0 +1,66 @@ + +module DDC.Driver.Build.Locate + (locateModuleFromPaths) +where +import DDC.Core.Module +import qualified DDC.Core.Pretty as P +import Control.Monad +import Control.Monad.Trans.Except +import Control.Monad.IO.Class +import Data.Maybe +import System.FilePath +import qualified System.Directory as Directory + + +-- | Locate the source file for a module, starting from the given list of base paths. +-- If the module cannot be found, or is found from multiple paths then throw +-- an error in the monad. +-- +locateModuleFromPaths + :: [FilePath] -- ^ Base paths. + -> ModuleName -- ^ Module name. + -> String -- ^ Source file extension + -> ExceptT String IO FilePath + +locateModuleFromPaths pathsBase name ext + = do + mPaths <- liftIO + $ liftM catMaybes + $ mapM (\d -> locateModuleFromPath d name ext) pathsBase + + case mPaths of + [] -> throwE $ unlines + $ [ "Cannot locate source for module '" + ++ (P.renderIndent $ P.ppr name) + ++ "' from base directories:" ] + ++ [" " ++ dir | dir <- pathsBase] + + [path] -> return path + + paths -> throwE $ unlines + $ [ "Source for module '" + ++ (P.renderIndent $ P.ppr name ) + ++ "' found at multiple paths:" ] + ++ [" " ++ dir | dir <- paths] + + +-- | Given the path of a .build spec, and a module name, yield the path where +-- the source of the module should be. +locateModuleFromPath + :: FilePath -- ^ Base path. + -> ModuleName -- ^ Module name. + -> String -- ^ Source file extension. + -> IO (Maybe FilePath) + +locateModuleFromPath pathBase (ModuleName parts) ext + = let + go [] = ext + go [p] = p <.> ext + go (p : ps) = p go ps + + in do + let pathFile = pathBase go parts + exists <- Directory.doesFileExist pathFile + if exists + then return $ Just pathFile + else return Nothing diff --git a/DDC/Driver/Build/Main.hs b/DDC/Driver/Build/Main.hs new file mode 100644 --- /dev/null +++ b/DDC/Driver/Build/Main.hs @@ -0,0 +1,117 @@ + +module DDC.Driver.Build.Main + ( buildSpec + , buildComponent + , buildModule) +where +import DDC.Driver.Command.Compile +import DDC.Driver.Build.Locate +import DDC.Driver.Config +import DDC.Build.Spec +import Control.Monad +import Control.Monad.Trans.Except +import Control.Monad.IO.Class +import DDC.Build.Interface.Store (Store) +import qualified DDC.Core.Module as C + + +--------------------------------------------------------------------------------------------------- +-- | Build all the components defined by a build spec. +buildSpec + :: Config -- ^ Build config. + -> Store -- ^ Interface store. + -> Spec -- ^ Build spec. + -> ExceptT String IO () + +buildSpec config store spec + = do mapM_ (buildComponent config store) + (specComponents spec) + + +--------------------------------------------------------------------------------------------------- +-- | Build a single component of a build spec. +buildComponent + :: Config -- ^ Build config. + -> Store -- ^ Interface store. + -> Component -- ^ Component to build. + -> ExceptT String IO () + +buildComponent config store component@SpecLibrary{} + = do + when (configLogBuild config) + $ liftIO $ putStrLn $ "* Building library " ++ specLibraryName component + + buildLibrary config store + $ specLibraryTetraModules component + + return () + +buildComponent config store component@SpecExecutable{} + = do + when (configLogBuild config) + $ liftIO $ putStrLn $ "* Building executable " ++ specExecutableName component + + buildExecutable config store + (specExecutableTetraMain component) + (specExecutableTetraOther component) + + return () + + +--------------------------------------------------------------------------------------------------- +-- | Build a library consisting of several modules. +buildLibrary + :: Config -- ^ Build config + -> Store -- ^ Interface store. + -> [C.ModuleName] -- ^ Names of modules still to build + -> ExceptT String IO () + +buildLibrary config store ms0 + = go ms0 + where + go [] + = return () + + go (m : more) + = do buildModule config store m + go more + + +--------------------------------------------------------------------------------------------------- +-- | Build an executable consisting of several modules. +buildExecutable + :: Config -- ^ Build config. + -> Store -- ^ Interface store. + -> C.ModuleName -- ^ Name of main module. + -> [C.ModuleName] -- ^ Names of dependency modules + -> ExceptT String IO () + +buildExecutable config store mMain msOther0 + = go msOther0 + where + go [] + = do let dirs = configModuleBaseDirectories config + path <- locateModuleFromPaths dirs mMain "ds" + _ <- cmdCompile config True store path + return () + + go (m : more) + = do buildModule config store m + go more + + +--------------------------------------------------------------------------------------------------- +-- | Build a single module. +buildModule + :: Config -- ^ Build config. + -> Store -- ^ Interface store. + -> C.ModuleName -- ^ Module name. + -> ExceptT String IO () + +buildModule config store name + = do let dirs = configModuleBaseDirectories config + path <- locateModuleFromPaths dirs name "ds" + _ <- cmdCompile config False store path + return () + + diff --git a/DDC/Driver/Command/BaseBuild.hs b/DDC/Driver/Command/BaseBuild.hs --- a/DDC/Driver/Command/BaseBuild.hs +++ b/DDC/Driver/Command/BaseBuild.hs @@ -8,23 +8,22 @@ import DDC.Driver.Command.Compile import System.FilePath import System.Directory -import Control.Monad.Trans.Error +import Control.Monad.Trans.Except import Control.Monad.IO.Class import Control.Monad - - -baseLiteFiles :: Builder -> [FilePath] -baseLiteFiles builder - = let _bits = show $ archPointerWidth $ platformArch $ buildTarget builder - in [ "lite" "base" "Data" "Numeric" "Bool.dcl" - , "lite" "base" "Data" "Numeric" "Int.dcl" - , "lite" "base" "Data" "Numeric" "Nat.dcl" ] +import DDC.Build.Interface.Store (Store) baseSaltFiles :: Builder -> [FilePath] baseSaltFiles builder = let bits = show $ archPointerWidth $ platformArch $ buildTarget builder - in [ "salt" "runtime" ++ bits "Object.dcs" ] + runtime = "salt" "runtime" ++ bits + in [ runtime "debug" "Trace.dcs" + , runtime "primitive" "Array.dcs" + , runtime "primitive" "Ref.dcs" + , runtime "primitive" "Text.dcs" + , runtime "Apply.dcs" + , runtime "Object.dcs" ] baseSeaFiles :: Builder -> [FilePath] @@ -33,8 +32,8 @@ -- Buid the base libraries and runtime system. -cmdBaseBuild :: Config -> ErrorT String IO () -cmdBaseBuild config +cmdBaseBuild :: Config -> Store -> ExceptT String IO () +cmdBaseBuild config store = do let builder = configBuilder config let target = buildTarget builder @@ -43,16 +42,11 @@ when (not exists) $ liftIO $ createDirectory $ buildBaseLibDir builder - -- Build all the .dcl files. - let srcLiteFiles = map (buildBaseSrcDir builder ) (baseLiteFiles builder) - let objLiteFiles = map (flip replaceExtension "o") srcLiteFiles - mapM_ (cmdCompile config) srcLiteFiles - -- Build all the .dcs files. let config' = config { configInferTypes = True } let srcSaltFiles = map (buildBaseSrcDir builder ) (baseSaltFiles builder) let objSaltFiles = map (flip replaceExtension "o") srcSaltFiles - mapM_ (cmdCompile config') srcSaltFiles + mapM_ (cmdCompile config' False store) srcSaltFiles -- Build all the .c files. let srcSeaFiles = map (buildBaseSrcDir builder ) (baseSeaFiles builder) @@ -60,7 +54,7 @@ liftIO $ zipWithM_ (buildCC builder) srcSeaFiles objSeaFiles -- All the .o files - let objFiles = objLiteFiles ++ objSaltFiles ++ objSeaFiles + let objFiles = objSaltFiles ++ objSeaFiles -- Link the .o files into a static library. let staticRuntime diff --git a/DDC/Driver/Command/Build.hs b/DDC/Driver/Command/Build.hs new file mode 100644 --- /dev/null +++ b/DDC/Driver/Command/Build.hs @@ -0,0 +1,54 @@ + +module DDC.Driver.Command.Build + (cmdBuild) +where +import DDC.Driver.Config +import DDC.Driver.Build.Main +import DDC.Driver.Command.Compile +import DDC.Base.Pretty +import DDC.Build.Interface.Store (Store) +import Control.Monad.Trans.Except +import Control.Monad.IO.Class +import qualified System.FilePath as FilePath +import qualified DDC.Build.Spec.Parser as Spec +import qualified DDC.Build.Builder as Builder +import qualified Data.List as List + + +-- Perform a build following a build specification. +cmdBuild :: Config -> Store -> FilePath -> ExceptT String IO () +cmdBuild config store filePath + + -- Build from a build spec file + | ".build" <- FilePath.takeExtension filePath + = do + -- Search for modules in the base library as well as the same directory + -- the build file is in. + let config' + = config + { configModuleBaseDirectories + = List.nub + $ configModuleBaseDirectories config + ++ [ FilePath.takeDirectory filePath + , Builder.buildBaseSrcDir (configBuilder config) + FilePath. "tetra" FilePath. "base" ] + } + + -- Parse the spec file. + str <- liftIO $ readFile filePath + case Spec.parseBuildSpec filePath str of + Left err -> throwE $ renderIndent $ ppr err + Right spec -> buildSpec config' store spec + + + -- If we were told to build a source file then just compile it instead. + -- This is probably the least surprising behaviour. + | ".ds" <- FilePath.takeExtension filePath + = do cmdCompileRecursive config False store filePath + return () + + -- Don't know how to build from this file. + | otherwise + = let ext = FilePath.takeExtension filePath + in throwE $ "Cannot build from '" ++ ext ++ "' files." + diff --git a/DDC/Driver/Command/Check.hs b/DDC/Driver/Command/Check.hs --- a/DDC/Driver/Command/Check.hs +++ b/DDC/Driver/Command/Check.hs @@ -24,7 +24,8 @@ import DDC.Driver.Stage import DDC.Driver.Output import DDC.Driver.Config -import DDC.Interface.Source +import DDC.Driver.Command.Compile +import DDC.Driver.Interface.Source import DDC.Build.Language import DDC.Build.Pipeline import DDC.Core.Fragment @@ -32,20 +33,20 @@ import DDC.Core.Parser import DDC.Core.Lexer import DDC.Core.Module -import DDC.Core.Exp +import DDC.Core.Exp.Annot import DDC.Core.Pretty -import DDC.Core.Compounds import DDC.Type.Transform.SpreadT import DDC.Type.Universe import DDC.Type.Equiv -import Control.Monad.Trans.Error +import Control.Monad.Trans.Except import Control.Monad.IO.Class -import qualified DDC.Base.Parser as BP -import qualified DDC.Type.Check as T -import qualified DDC.Core.Check as C import Control.Monad import System.FilePath import System.Directory +import DDC.Build.Interface.Store (Store) +import qualified DDC.Base.Parser as BP +import qualified DDC.Type.Check as T +import qualified DDC.Core.Check as C -- Module ----------------------------------------------------------------------------------------- @@ -58,14 +59,15 @@ -- cmdCheckFromFile :: Config -- ^ Driver config. + -> Store -- ^ Interface store. -> FilePath -- ^ Module file path. - -> ErrorT String IO () + -> ExceptT String IO () -cmdCheckFromFile config filePath +cmdCheckFromFile config store filePath -- Check a Disciple Source Tetra module. - | ".dst" <- takeExtension filePath - = cmdCheckSourceTetraFromFile config filePath + | ".ds" <- takeExtension filePath + = cmdCheckSourceTetraFromFile config store filePath -- Check a module in some fragment of Disciple Core. | Just language <- languageOfExtension (takeExtension filePath) @@ -74,51 +76,56 @@ -- Don't know how to check this file. | otherwise = let ext = takeExtension filePath - in throwError $ "Cannot check '" ++ ext ++ "'files." + in throwE $ "Cannot check '" ++ ext ++ "'files." --------------------------------------------------------------------------------------------------- -- | Check a Disciple Source Tetra module from a file. cmdCheckSourceTetraFromFile :: Config -- ^ Driver config. + -> Store -- ^ Interface store. -> FilePath -- ^ Module file path. - -> ErrorT String IO () + -> ExceptT String IO () -cmdCheckSourceTetraFromFile config filePath +cmdCheckSourceTetraFromFile config store filePath = do -- Check that the file exists. exists <- liftIO $ doesFileExist filePath when (not exists) - $ throwError $ "No such file " ++ show filePath + $ throwE $ "No such file " ++ show filePath + -- Call the compiler to build/load all dependent modules. + cmdCompileRecursive config False store filePath + -- Read in the source file. src <- liftIO $ readFile filePath - cmdCheckSourceTetraFromString config (SourceFile filePath) src + cmdCheckSourceTetraFromString config store (SourceFile filePath) src --------------------------------------------------------------------------------------------------- -- | Check a Disciple Source Tetra module from a string. --- Any errors are thrown in the `ErrorT` monad. +-- Any errors are thrown in the `ExceptT` monad. cmdCheckSourceTetraFromString :: Config -- ^ Driver config. + -> Store -- ^ Interface store -> Source -- ^ Source of the code. -> String -- ^ Program module text. - -> ErrorT String IO () + -> ExceptT String IO () -cmdCheckSourceTetraFromString config source str +cmdCheckSourceTetraFromString config store source str = let pmode = prettyModeOfConfig $ configPretty config pipeLoad = pipeText (nameOfSource source) (lineStartOfSource source) str - $ stageSourceTetraLoad config source + $ stageSourceTetraLoad config source store [ PipeCoreOutput pmode SinkDiscard ] in do errs <- liftIO pipeLoad case errs of [] -> return () - es -> throwError $ renderIndent $ vcat $ map ppr es + es -> throwE $ renderIndent $ vcat $ map ppr es --------------------------------------------------------------------------------------------------- @@ -127,7 +134,7 @@ :: Config -- ^ Driver config. -> Language -- ^ Core language definition. -> FilePath -- ^ Module file path. - -> ErrorT String IO () + -> ExceptT String IO () cmdCheckCoreFromFile config language filePath | Language bundle <- language @@ -138,7 +145,7 @@ $ (if configInferTypes config then C.Synth else C.Recon) case mModule of - (Left err, _ct) -> throwError (renderIndent $ ppr err) + (Left err, _ct) -> throwE (renderIndent $ ppr err) (Right _, _ct) -> return () @@ -149,7 +156,7 @@ -> Source -- ^ Source of the program text. -> String -- ^ Program text. -> C.Mode n -- ^ Type checker mode. - -> ErrorT String IO (Module (AnTEC BP.SourcePos n) n) + -> ExceptT String IO (Module (AnTEC BP.SourcePos n) n) cmdCheckCoreFromString fragment source str mode = do @@ -158,7 +165,7 @@ mode str case mModule of - (Left err, _ct) -> throwError (renderIndent $ ppr err) + (Left err, _ct) -> throwE (renderIndent $ ppr err) (Right mm, _ct) -> return mm diff --git a/DDC/Driver/Command/Compile.hs b/DDC/Driver/Command/Compile.hs --- a/DDC/Driver/Command/Compile.hs +++ b/DDC/Driver/Command/Compile.hs @@ -1,40 +1,272 @@ module DDC.Driver.Command.Compile - (cmdCompile) + ( cmdCompileRecursive + , cmdCompileRecursiveDS + , cmdLoadOrCompile + , cmdCompile + , getModificationTimeIfExists) where import DDC.Driver.Stage -import DDC.Interface.Source +import DDC.Driver.Config +import DDC.Driver.Interface.Source import DDC.Build.Pipeline +import DDC.Build.Interface.Base +import DDC.Data.Canned +import DDC.Data.Token import System.FilePath import System.Directory import Control.Monad -import Control.Monad.Trans.Error +import Control.Monad.Trans.Except import Control.Monad.IO.Class -import qualified DDC.Core.Pretty as P +import Data.Time.Clock +import Data.IORef +import qualified DDC.Driver.Build.Locate as Locate +import qualified DDC.Build.Builder as Builder +import qualified DDC.Source.Tetra.Module as SE +import qualified DDC.Source.Tetra.Lexer as SE +import qualified DDC.Source.Tetra.Parser as SE +import qualified DDC.Core.Pretty as P +import qualified DDC.Core.Module as C +import qualified DDC.Core.Parser as C +import qualified DDC.Core.Lexer as C +import qualified DDC.Base.Parser as BP +import qualified DDC.Version as Version +import qualified Data.List as List +import DDC.Driver.Command.Flow.ToTetra +import qualified DDC.Core.Flow as Flow --- | Compile a source module into a @.o@ file. -cmdCompile :: Config -> FilePath -> ErrorT String IO () -cmdCompile config filePath +import DDC.Build.Interface.Store (Store) +import qualified DDC.Build.Interface.Store as Store + + +--------------------------------------------------------------------------------------------------- +-- | Recursively compile source modules into @.o@ files, +-- or load existing interfaces if we have them and the @.o@ file is +-- still fresh. +-- +-- * Interface files that are loaded or generated during compilation +-- are added to the interface store. +-- +cmdCompileRecursive + :: Config -- ^ Build driver config. + -> Bool -- ^ Build an exectable. + -> Store -- ^ Interface store. + -> FilePath -- ^ Path to file to compile + -> ExceptT String IO () + +cmdCompileRecursive config bBuildExe store filePath + | takeExtension filePath == ".ds" + = do cmdCompileRecursiveDS config bBuildExe store [filePath] [] + + | otherwise + = do cmdCompile config bBuildExe store filePath + + +--------------------------------------------------------------------------------------------------- +-- | Recursively compile @.ds@ source modules into @.o@ files, +-- or load existing interfaces if we have them and the @.o@ file is +-- still fresh. +-- +-- * Interface files that are loaded or generated during compilation +-- are added to the interface store. +-- +cmdCompileRecursiveDS + :: Config -- ^ Build driver config. + -> Bool -- ^ Build an executable. + -> Store -- ^ Inferface store. + -> [FilePath] -- ^ Names of source files still to load. + -> [FilePath] -- ^ Names of source files currently blocked. + -> ExceptT String IO () + +cmdCompileRecursiveDS _config _bBuildExe _store [] _fsBlocked + = return () + +cmdCompileRecursiveDS config bBuildExe store (filePath:fs) fsBlocked = do + -- Check if the requested file exists. + exists <- liftIO $ doesFileExist filePath + when (not exists) + $ throwE $ "No such file " ++ show filePath + -- Read in the source file. + src <- liftIO $ readFile filePath + + -- Parse just the header of the module to determine what + -- other modules it imports. + modNamesNeeded <- tasteNeeded filePath src + + -- Names of all the modules that we have interfaces for. + modsNamesHave <- liftIO $ Store.getModuleNames store + + -- Names of modules that we are missing interfaces for. + let missing = filter (\m -> not $ elem m modsNamesHave) + $ modNamesNeeded + + case missing of + -- We've already got all the interfaces needed by the + -- current module. + [] -> do + -- Compile the current module. + cmdLoadOrCompile config bBuildExe store filePath + + -- Build other modules that are still queued. + cmdCompileRecursiveDS config bBuildExe store fs [] + + -- We still need to load or compile dependent modules. + ms -> do + -- Determine filepaths for all dependent modules. + fsMore <- mapM (locateModuleFromConfig config) ms + + -- Check that we're not on a recursive loop, + -- trying to compile a module that's importing itself. + let fsRec = List.intersect fsMore fsBlocked + when (not $ null fsRec) + $ throwE $ unlines + $ [ "Cannot build recursive module" ] + ++ [ " " ++ show fsRec ] + + -- Shift the current module to the end of the queue, + -- compiling the dependent modules first. + cmdCompileRecursiveDS config bBuildExe store + (List.nub $ fsMore ++ fs ++ [filePath]) + (filePath : fsBlocked) + + +--------------------------------------------------------------------------------------------------- +-- | Load the interface correponding to a source file, +-- or re-compile the source if it's fresher than the interface. +-- +-- * Interfaces for dependent modules must already be in the +-- interface store. +-- +cmdLoadOrCompile + :: Config -- ^ Build driver config. + -> Bool -- ^ Build an exeecutable. + -> Store -- ^ Interface store. + -> FilePath -- ^ Path to source file. + -> ExceptT String IO () + +cmdLoadOrCompile config buildExe store filePath + = do + -- Check that the source file exists. exists <- liftIO $ doesFileExist filePath when (not exists) - $ throwError $ "No such file " ++ show filePath + $ throwE $ "No such file " ++ show filePath + -- Read in the source file. src <- liftIO $ readFile filePath + Just timeDS <- liftIO $ getModificationTimeIfExists filePath + + -- Parse just the header of the module to determine what other modules + -- it imports. + modNamesNeeded <- tasteNeeded filePath src + + -- It's safe to reload the module from an inteface file if: + -- 1. There is an existing interface which is fresher than the source. + -- 2. There is an existing object which is fresher than the source. + -- 3. There is an existing interface which is fresher than the + -- interfaces of all dependencies. + -- + -- Additionally, we force rebuild for the top level module, because + -- that's what was mentioned on the command line. We're trying to + -- follow the principle of least surprise in this regard. + -- + let filePathO = objectPathOfConfig config filePath + let filePathDI = replaceExtension filePathO ".di" + mTimeO <- liftIO $ getModificationTimeIfExists filePathO + mTimeDI <- liftIO $ getModificationTimeIfExists filePathDI + meta' <- liftIO $ Store.getMeta store + + let loadOrCompile + -- object and interface are fresher than source. + | Just timeO <- mTimeO, timeDS < timeO + , Just timeDI <- mTimeDI, timeDS < timeDI + + -- Interface at least as fresh than all dependencies. + -- See Note: Timestamp accuracy during rebuild. + , and [ Store.metaTimeStamp m <= timeDI + | m <- meta' + , elem (Store.metaModuleName m) modNamesNeeded ] + + -- this is not the top-level module. + , not $ takeFileName filePath == "Main.ds" + = do + result <- liftIO $ Store.load filePathDI + case result of + Left err -> throwE $ P.renderIndent $ P.ppr err + Right int -> liftIO $ Store.wrap store int + + | otherwise + = do cmdCompile config buildExe store filePath + + loadOrCompile + + +--------------------------------------------------------------------------------------------------- +-- | Compile a source module into a @.o@ file. +-- +-- * Interfaces for dependent modules must already be in the interface +-- store. +-- +-- * This produces an @.o@ file next to the source file, and may also +-- produce a @.di@ interface, depending on what sort of source file +-- we're compiling. +-- +-- * If compilation produces an interface then it is added to the +-- existing store. +-- +cmdCompile + :: Config -- ^ Build driver config. + -> Bool -- ^ Build an executable. + -> Store -- ^ Interface store. + -> FilePath -- ^ Path to source file. + -> ExceptT String IO () + +cmdCompile config bBuildExe' store filePath + = do + let buildExe + = takeBaseName filePath == "Main" + && bBuildExe' + + if buildExe + then liftIO $ putStrLn $ "* Compiling " ++ filePath ++ " as executable" + else liftIO $ putStrLn $ "* Compiling " ++ filePath + let ext = takeExtension filePath let source = SourceFile filePath - -- Decide what to do based on file extension. + -- Read in the source file. + exists <- liftIO $ doesFileExist filePath + when (not exists) + $ throwE $ "No such file " ++ show filePath + + src <- liftIO $ readFile filePath + + -- If we're building an executable, then get paths to the other object + -- files that we need to link with. + metas <- liftIO $ Store.getMeta store + let pathsDI = map Store.metaFilePath metas + let otherObjs + | buildExe = Just $ map (\path -> replaceExtension path "o") pathsDI + | otherwise = Nothing + + -- During complation of this module the intermediate code will be + -- stashed in these refs. We will use the intermediate code to build + -- the interface for this module. + refTetra <- liftIO $ newIORef Nothing + refSalt <- liftIO $ newIORef Nothing + + -- Use the file extension to decide what compilation pipeline to use. let make -- Compile a Source Tetra module. - | ext == ".dst" + | ext == ".ds" = liftIO $ pipeText (nameOfSource source) (lineStartOfSource source) src - $ stageSourceTetraLoad config source - [ PipeCoreReannotate (const ()) - [ stageTetraToSalt config source pipesSalt ]] + $ stageSourceTetraLoad config source store + [ PipeCoreHacks (Canned $ \m -> writeIORef refTetra (Just m) >> return m) + [ PipeCoreReannotate (const ()) + [ stageTetraToSalt config source pipesSalt ]]] -- Compile a Core Tetra module. | ext == ".dct" @@ -43,40 +275,179 @@ $ stageTetraLoad config source [ stageTetraToSalt config source pipesSalt ] - -- Compile a Core Lite module. - | ext == ".dcl" + -- Compile a Core Salt module. + | ext == ".dcs" = liftIO $ pipeText (nameOfSource source) (lineStartOfSource source) src - $ stageLiteLoad config source - [ stageLiteOpt config source - [ stageLiteToSalt config source pipesSalt ]] + $ stageSaltLoad config source pipesSalt -- Compile a Core Salt module. - | ext == ".dcs" + | ext == ".dcf" = liftIO $ pipeText (nameOfSource source) (lineStartOfSource source) src - $ stageSaltLoad config source pipesSalt + $ pipelineFlowToTetra config Flow.defaultConfigScalar source pipesSalt -- Unrecognised. | otherwise - = throwError $ "Cannot compile '" ++ ext ++ "' files." + = throwE $ "Cannot compile '" ++ ext ++ "' files." pipesSalt = case configViaBackend config of ViaLLVM -> [ PipeCoreReannotate (const ()) - [ stageSaltOpt config source - [ stageSaltToLLVM config source - [ stageCompileLLVM config source filePath False ]]]] + [ stageSaltOpt config source + [ PipeCoreHacks (Canned $ \m -> writeIORef refSalt (Just m) >> return m) + [ stageSaltToLLVM config source + [ stageCompileLLVM config source filePath otherObjs ]]]]] ViaC -> [ PipeCoreReannotate (const ()) - [ stageSaltOpt config source - [ stageCompileSalt config source filePath False ]]] + [ stageSaltOpt config source + [ stageCompileSalt config source filePath False ]]] - -- Throw any errors that arose during compilation. + -- Run the compilation pipeline. errs <- make + + + -- Read back intermediate code from our refs. + -- This will be written out as part of the interface file for this module. + modTetra <- liftIO $ readIORef refTetra + modSalt <- liftIO $ readIORef refSalt + + -- Handle errors ------------------------ case errs of - [] -> return () - es -> throwError $ P.renderIndent $ P.vcat $ map P.ppr es + -- There was some error during compilation. + es@(_:_) + -> throwE $ P.renderIndent $ P.vcat $ map P.ppr es + -- Compilation was successful, + -- but we need to have produced at least a Tetra or Salt module + -- before we can build the interface file. + [] + | Just (mn : _) + <- sequence + [ liftM C.moduleName modTetra + , liftM C.moduleName modSalt ] + -> do + -- write out the interface file. + let pathO = objectPathOfConfig config filePath + let pathDI = replaceExtension pathO ".di" + + timeDI <- liftIO $ getCurrentTime + let int = Interface + { interfaceVersion = Version.version + , interfaceFilePath = pathDI + , interfaceTimeStamp = timeDI + , interfaceModuleName = mn + , interfaceTetraModule = modTetra + , interfaceSaltModule = modSalt } + + liftIO $ writeFile pathDI + $ P.renderIndent $ P.ppr int + + -- Add the new interface to the store. + liftIO $ Store.wrap store int + + return () + + -- Compilation was successful, + -- but we didn't get enough build products to produce an interface file. + | otherwise + -> return () + + +--------------------------------------------------------------------------------------------------- +-- Taste the header of the module to see what other modules it depends on. +-- Only Source modules can import other modules. +-- For core modules, all the required information is listed explicitly +-- in the module itself. +tasteNeeded + :: FilePath -- ^ Path of module. + -> String -- ^ Module source. + -> ExceptT String IO [C.ModuleName] + +tasteNeeded filePath src + | takeExtension filePath == ".ds" + = do + -- Lex the module, dropping all tokens after and including + -- the first 'where', because we only need the module header. + let tokens + = dropBody + $ SE.lexModuleString filePath 1 src + + let context + = C.Context + { C.contextTrackedEffects = True + , C.contextTrackedClosures = True + , C.contextFunctionalEffects = False + , C.contextFunctionalClosures = False + , C.contextMakeStringName = Nothing } + + case BP.runTokenParser C.describeTok filePath + (SE.pModule context) tokens of + Left err -> throwE $ P.renderIndent $ P.ppr err + Right mm -> return $ SE.moduleImportModules mm + + | otherwise + = return [] + + +--------------------------------------------------------------------------------------------------- +-- | Given a driver config, locate the module with the given name. +locateModuleFromConfig + :: Config + -> C.ModuleName + -> ExceptT String IO FilePath + +locateModuleFromConfig config mname + = do -- Automatically look for modules in the base library. + let baseDirs + = configModuleBaseDirectories config + ++ [Builder.buildBaseSrcDir (configBuilder config) + "tetra" "base"] + + Locate.locateModuleFromPaths baseDirs mname ".ds" + + +-- | If the given file exists then get its modification time, +-- otherwise Nothing. +getModificationTimeIfExists :: FilePath -> IO (Maybe UTCTime) +getModificationTimeIfExists path + = do exists <- doesFileExist path + if exists + then do + timeStamp <- getModificationTime path + return $ Just timeStamp + + else return Nothing + + +-- | Drop tokens after and including the first 'where' keyword. +-- When parsing just the module header we can drop these tokens +-- because they only represent the body of the module. +dropBody :: [Token (C.Tok n)] -> [Token (C.Tok n)] +dropBody toks = go toks + where go [] = [] + go (Token { tokenTok = C.KA C.KWhere} : _) = [] + go (t : moar) = t : go moar + + +-- [Note: Timestamp acccuracy during rebuild] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- There's an ugly system where if the underlying file system does not +-- support file time stamps with sub-second accuracy, then the timestamps +-- of the interface files we compile in this run will have more accuracy +-- than the ones we load from the file system. +-- +-- The problem with inaccurate timestamps is that if we compiled two +-- dependent modules within the same second, then both will have the +-- same time-stamp and none is fresher than the other. +-- +-- Due to this we allow the time stamp of dependent interface files to +-- be equal so that they will not be rebuilt in this situation. +-- +-- We assume that if any process legitimately changes a dependent +-- object file then this will be done at least a second after we first +-- created it. +-- diff --git a/DDC/Driver/Command/Flow/Concretize.hs b/DDC/Driver/Command/Flow/Concretize.hs --- a/DDC/Driver/Command/Flow/Concretize.hs +++ b/DDC/Driver/Command/Flow/Concretize.hs @@ -6,9 +6,9 @@ import DDC.Build.Language.Flow import DDC.Driver.Stage import DDC.Driver.Config -import DDC.Interface.Source +import DDC.Driver.Interface.Source import DDC.Data.Canned -import Control.Monad.Trans.Error +import Control.Monad.Trans.Except import Control.Monad.IO.Class import qualified DDC.Core.Flow.Transform.Concretize as Concretize import qualified DDC.Core.Check as C @@ -20,7 +20,7 @@ :: Config -> Source -- ^ Source of the code. -> String -- ^ Program module text. - -> ErrorT String IO () + -> ExceptT String IO () cmdFlowConcretize config source sourceText = let pmode = prettyModeOfConfig $ configPretty config @@ -39,7 +39,7 @@ errs <- liftIO pipeConcretize case errs of [] -> return () - es -> throwError $ P.renderIndent $ P.vcat $ map P.ppr es + es -> throwE $ P.renderIndent $ P.vcat $ map P.ppr es diff --git a/DDC/Driver/Command/Flow/Lower.hs b/DDC/Driver/Command/Flow/Lower.hs --- a/DDC/Driver/Command/Flow/Lower.hs +++ b/DDC/Driver/Command/Flow/Lower.hs @@ -2,11 +2,11 @@ module DDC.Driver.Command.Flow.Lower (cmdFlowLower) where -import DDC.Driver.Stage as Driver -import DDC.Driver.Config -import DDC.Interface.Source +import DDC.Driver.Stage +import DDC.Driver.Config as Driver +import DDC.Driver.Interface.Source import DDC.Build.Pipeline -import Control.Monad.Trans.Error +import Control.Monad.Trans.Except import Control.Monad.IO.Class import qualified DDC.Base.Pretty as P import qualified DDC.Core.Check as C @@ -20,7 +20,7 @@ -> Flow.Config -- ^ Config for the lowering transform. -> Source -- ^ Source of the code. -> String -- ^ Program module text. - -> ErrorT String IO () + -> ExceptT String IO () cmdFlowLower configDriver configLower @@ -35,7 +35,9 @@ $ stageFlowLoad configDriver source [ stageFlowPrep configDriver source [ PipeCoreCheck Flow.fragment C.Recon SinkDiscard - [ stageFlowLower configDriver configLower source [ pipeFinal ]]]] + [ stageFlowLower configDriver configLower source + [ PipeCoreOutput pmode SinkStdout , pipeFinal ]]]] + -- [ pipeFinal ]]]] pipeFinal | configTaintAvoidTypeChecks configDriver @@ -43,11 +45,11 @@ | otherwise = PipeCoreCheck Flow.fragment C.Recon SinkDiscard - [ PipeCoreOutput pmode SinkStdout ] + [] -- [ PipeCoreOutput pmode SinkStdout ] in do errs <- liftIO pipeLower case errs of [] -> return () - es -> throwError $ P.renderIndent $ P.vcat $ map P.ppr es + es -> throwE $ P.renderIndent $ P.vcat $ map P.ppr es diff --git a/DDC/Driver/Command/Flow/Melt.hs b/DDC/Driver/Command/Flow/Melt.hs --- a/DDC/Driver/Command/Flow/Melt.hs +++ b/DDC/Driver/Command/Flow/Melt.hs @@ -2,12 +2,12 @@ module DDC.Driver.Command.Flow.Melt (cmdFlowMelt) where -import DDC.Interface.Source +import DDC.Driver.Interface.Source import DDC.Driver.Stage import DDC.Driver.Config import DDC.Build.Pipeline import DDC.Build.Language.Flow -import Control.Monad.Trans.Error +import Control.Monad.Trans.Except import Control.Monad.IO.Class import qualified DDC.Core.Check as C import qualified DDC.Base.Pretty as P @@ -21,7 +21,7 @@ :: Config -- ^ Driver config. -> Source -- ^ Source of the code. -> String -- ^ Program module text. - -> ErrorT String IO () + -> ExceptT String IO () cmdFlowMelt config source sourceText = let pmode = prettyModeOfConfig $ configPretty config @@ -41,7 +41,7 @@ errs <- liftIO pipeMelt case errs of [] -> return () - es -> throwError $ P.renderIndent $ P.vcat $ map P.ppr es + es -> throwE $ P.renderIndent $ P.vcat $ map P.ppr es diff --git a/DDC/Driver/Command/Flow/Prep.hs b/DDC/Driver/Command/Flow/Prep.hs --- a/DDC/Driver/Command/Flow/Prep.hs +++ b/DDC/Driver/Command/Flow/Prep.hs @@ -4,9 +4,9 @@ where import DDC.Driver.Stage import DDC.Driver.Config -import DDC.Interface.Source +import DDC.Driver.Interface.Source import DDC.Build.Pipeline -import Control.Monad.Trans.Error +import Control.Monad.Trans.Except import Control.Monad.IO.Class import qualified DDC.Core.Check as C import qualified DDC.Base.Pretty as P @@ -18,7 +18,7 @@ :: Config -- ^ Driver config. -> Source -- ^ Source of the code. -> String -- ^ Program module text. - -> ErrorT String IO () + -> ExceptT String IO () cmdFlowPrep config source sourceText = let pmode = prettyModeOfConfig $ configPretty config @@ -35,5 +35,5 @@ errs <- liftIO pipePrep case errs of [] -> return () - es -> throwError $ P.renderIndent $ P.vcat $ map P.ppr es + es -> throwE $ P.renderIndent $ P.vcat $ map P.ppr es diff --git a/DDC/Driver/Command/Flow/Rate.hs b/DDC/Driver/Command/Flow/Rate.hs --- a/DDC/Driver/Command/Flow/Rate.hs +++ b/DDC/Driver/Command/Flow/Rate.hs @@ -1,16 +1,18 @@ module DDC.Driver.Command.Flow.Rate - (cmdFlowRate) + ( cmdFlowRate + , cmdFlowRateLower ) where import DDC.Driver.Stage import DDC.Driver.Config -import DDC.Interface.Source +import DDC.Driver.Interface.Source import DDC.Build.Pipeline -import Control.Monad.Trans.Error +import Control.Monad.Trans.Except import Control.Monad.IO.Class import qualified DDC.Base.Pretty as P import qualified DDC.Core.Check as C import qualified DDC.Build.Language.Flow as Flow +import qualified DDC.Core.Flow as Flow -- | Perform rate inference to transform vector operations to series @@ -18,7 +20,7 @@ :: Config -- ^ Driver config. -> Source -- ^ Source of the code. -> String -- ^ Program module text. - -> ErrorT String IO () + -> ExceptT String IO () cmdFlowRate config source sourceText = let pmode = prettyModeOfConfig $ configPretty config @@ -36,5 +38,35 @@ errs <- liftIO pipeRate case errs of [] -> return () - es -> throwError $ P.renderIndent $ P.vcat $ map P.ppr es + es -> throwE $ P.renderIndent $ P.vcat $ map P.ppr es + + +-- | Perform rate inference, then lower +cmdFlowRateLower + :: Config -- ^ Driver config. + -> Flow.Config -- ^ Config for the lowering transform. + -> Source -- ^ Source of the code. + -> String -- ^ Program module text. + -> ExceptT String IO () + +cmdFlowRateLower config configLower source sourceText + = let pmode = prettyModeOfConfig $ configPretty config + + pipeRate + = pipeText (nameOfSource source) + (lineStartOfSource source) + sourceText + $ stageFlowLoad config source + [ stageFlowRate config source + [ stageFlowPrep config source + [ PipeCoreCheck Flow.fragment C.Recon SinkDiscard + [ stageFlowLower config configLower source + [ PipeCoreCheck Flow.fragment C.Recon SinkDiscard + [ PipeCoreOutput pmode SinkStdout ]]]]]] + + in do + errs <- liftIO pipeRate + case errs of + [] -> return () + es -> throwE $ P.renderIndent $ P.vcat $ map P.ppr es diff --git a/DDC/Driver/Command/Flow/Thread.hs b/DDC/Driver/Command/Flow/Thread.hs --- a/DDC/Driver/Command/Flow/Thread.hs +++ b/DDC/Driver/Command/Flow/Thread.hs @@ -2,14 +2,14 @@ module DDC.Driver.Command.Flow.Thread (cmdFlowThread) where -import DDC.Interface.Source -import DDC.Build.Pipeline -import DDC.Build.Language.Flow +import DDC.Driver.Interface.Source import DDC.Driver.Stage import DDC.Driver.Config +import DDC.Build.Pipeline +import DDC.Build.Language.Flow import DDC.Core.Fragment import DDC.Data.Canned -import Control.Monad.Trans.Error +import Control.Monad.Trans.Except import Control.Monad.IO.Class import qualified DDC.Core.Transform.Thread as Thread import qualified DDC.Core.Flow.Transform.Thread as Flow @@ -25,7 +25,7 @@ :: Config -- ^ Driver config. -> Source -- ^ Source of the code. -> String -- ^ Program module text. - -> ErrorT String IO () + -> ExceptT String IO () cmdFlowThread config source sourceText = let pmode = prettyModeOfConfig $ configPretty config @@ -48,5 +48,5 @@ errs <- liftIO pipeThread case errs of [] -> return () - es -> throwError $ P.renderIndent $ P.vcat $ map P.ppr es + es -> throwE $ P.renderIndent $ P.vcat $ map P.ppr es diff --git a/DDC/Driver/Command/Flow/ToTetra.hs b/DDC/Driver/Command/Flow/ToTetra.hs new file mode 100644 --- /dev/null +++ b/DDC/Driver/Command/Flow/ToTetra.hs @@ -0,0 +1,144 @@ + +module DDC.Driver.Command.Flow.ToTetra + ( cmdFlowToTetraFromFile + , cmdFlowToTetraCoreFromFile + , cmdFlowToTetraCoreFromString + , pipelineFlowToTetra) +where +import DDC.Driver.Stage +import DDC.Driver.Config +import DDC.Driver.Interface.Source +import DDC.Build.Pipeline +import DDC.Build.Language +import DDC.Core.Fragment +import DDC.Base.Pretty +import System.FilePath +import System.Directory +import Control.Monad.Trans.Except +import Control.Monad.IO.Class +import Control.Monad +import qualified DDC.Build.Language.Salt as Salt +import qualified DDC.Core.Salt as Salt +import qualified DDC.Build.Language.Flow as Flow +import qualified DDC.Core.Flow as Flow +import qualified DDC.Core.Check as C + +import DDC.Data.Canned +import qualified DDC.Core.Flow.Transform.Concretize as Concretize + + +------------------------------------------------------------------------------- +-- | Convert a module to Core Tetra. +-- The output is printed to @stdout@. +-- Any errors are thrown in the `ExceptT` monad. +-- +cmdFlowToTetraFromFile + :: Config -- ^ Driver config. + -> Flow.Config -- ^ Config for the lowering transform. + -> FilePath -- ^ Module file path. + -> ExceptT String IO () + +cmdFlowToTetraFromFile config configLower filePath + + -- Convert a module in some fragment of Disciple Core. + | Just language <- languageOfExtension (takeExtension filePath) + = cmdFlowToTetraCoreFromFile config configLower language filePath + + -- Don't know how to convert this file. + | otherwise + = let ext = takeExtension filePath + in throwE $ "Cannot convert '" ++ ext ++ "' files to Tetra." + + +------------------------------------------------------------------------------- +-- | Convert some fragment of Disciple Core to Core Tetra. +-- Works for the 'Flow' fragment. +-- The result is printed to @stdout@. +-- Any errors are thrown in the `ExceptT` monad. +-- +cmdFlowToTetraCoreFromFile + :: Config -- ^ Driver config. + -> Flow.Config -- ^ Config for the lowering transform. + -> Language -- ^ Core language definition. + -> FilePath -- ^ Module file path. + -> ExceptT String IO () + +cmdFlowToTetraCoreFromFile config configLower language filePath + = do + -- Check that the file exists. + exists <- liftIO $ doesFileExist filePath + when (not exists) + $ throwE $ "No such file " ++ show filePath + + -- Read in the source file. + src <- liftIO $ readFile filePath + + cmdFlowToTetraCoreFromString config configLower language (SourceFile filePath) src + + +------------------------------------------------------------------------------- +-- | Convert some fragment of Disciple Core to Core Tetra. +-- Works for the 'Tetra' fragment. +-- The result is printed to @stdout@. +-- Any errors are thrown in the `ExceptT` monad. +-- +cmdFlowToTetraCoreFromString + :: Config -- ^ Driver config. + -> Flow.Config -- ^ Config for the lowering transform. + -> Language -- ^ Language definition. + -> Source -- ^ Source of the code. + -> String -- ^ Program module text. + -> ExceptT String IO () + +cmdFlowToTetraCoreFromString config configLower language source str + | Language bundle <- language + , fragment <- bundleFragment bundle + , profile <- fragmentProfile fragment + = do + -- Language fragment name. + let fragName = profileName profile + + -- Pretty printer mode. + let pmode = prettyModeOfConfig $ configPretty config + + -- Decide what to do based on the fragment name. + let compile + -- Compile a Core Tetra module to Tetra. + | fragName == "Flow" + = liftIO + $ pipeText (nameOfSource source) (lineStartOfSource source) str + $ pipelineFlowToTetra config configLower source + [ PipeCoreCheck Salt.fragment C.Recon SinkDiscard + [] + , PipeCoreOutput pmode SinkStdout] + + -- Unrecognised fragment name or file extension. + | otherwise + = throwE $ "Cannot convert '" ++ fragName ++ "' modules to Salt." + + -- Throw any errors that arose during compilation + errs <- compile + case errs of + [] -> return () + es -> throwE $ renderIndent $ vcat $ map ppr es + + +pipelineFlowToTetra + :: Config + -> Flow.Config + -> Source + -> [PipeCore () Salt.Name] + -> PipeText Flow.Name Flow.Error + +pipelineFlowToTetra config configLower source pipesSalt + = stageFlowLoad config source + [ stageFlowRate config source + [ stageFlowPrep config source + [ PipeCoreCheck Flow.fragment C.Recon SinkDiscard + [ stageFlowLower config configLower source + [ PipeCoreHacks (Canned $ \m -> return $ Concretize.concretizeModule m) + [ PipeCoreCheck Flow.fragment C.Recon SinkDiscard + [ stageFlowWind config source + [ PipeCoreCheck Flow.fragment C.Recon SinkDiscard + [ stageFlowToTetra config source + pipesSalt]]]]]]]]] diff --git a/DDC/Driver/Command/Flow/Wind.hs b/DDC/Driver/Command/Flow/Wind.hs --- a/DDC/Driver/Command/Flow/Wind.hs +++ b/DDC/Driver/Command/Flow/Wind.hs @@ -4,9 +4,9 @@ where import DDC.Driver.Stage import DDC.Driver.Config -import DDC.Interface.Source +import DDC.Driver.Interface.Source import DDC.Build.Pipeline -import Control.Monad.Trans.Error +import Control.Monad.Trans.Except import Control.Monad.IO.Class import qualified DDC.Base.Pretty as P import qualified DDC.Core.Check as C @@ -18,7 +18,7 @@ :: Config -> Source -- ^ Source of the code. -> String -- ^ Program module text. - -> ErrorT String IO () + -> ExceptT String IO () cmdFlowWind config source sourceText = let pmode = prettyModeOfConfig $ configPretty config @@ -43,4 +43,4 @@ errs <- liftIO pipeLower case errs of [] -> return () - es -> throwError $ P.renderIndent $ P.vcat $ map P.ppr es + es -> throwE $ P.renderIndent $ P.vcat $ map P.ppr es diff --git a/DDC/Driver/Command/Load.hs b/DDC/Driver/Command/Load.hs --- a/DDC/Driver/Command/Load.hs +++ b/DDC/Driver/Command/Load.hs @@ -5,31 +5,41 @@ , cmdLoadSourceTetraFromString , cmdLoadCoreFromFile , cmdLoadCoreFromString - , cmdLoadSimplifier) + , cmdLoadSimplifier + , cmdLoadSimplifierIntoBundle) where -import DDC.Interface.Source +import DDC.Driver.Command.Compile +import DDC.Driver.Command.Read +import DDC.Driver.Stage +import DDC.Driver.Config +import DDC.Driver.Interface.Source import DDC.Build.Pipeline import DDC.Build.Language import DDC.Core.Simplifier.Parser import DDC.Core.Transform.Reannotate -import DDC.Driver.Command.Read -import DDC.Driver.Stage -import DDC.Driver.Config -import DDC.Core.Annot.AnTEC +import DDC.Core.Exp.Annot.AnTEC import DDC.Core.Pretty +import DDC.Data.SourcePos import Control.Monad -import Control.Monad.Trans.Error +import Control.Monad.Trans.Except import Control.Monad.IO.Class +import Control.DeepSeq import System.FilePath import System.Directory +import DDC.Build.Interface.Store (Store) import qualified Data.Map as Map import qualified DDC.Core.Check as C +import qualified DDC.Build.Language.Tetra as Tetra +import qualified DDC.Build.Spec.Parser as Spec +import qualified DDC.Build.Interface.Load as Interface +import qualified DDC.Core.Tetra as Tetra -------------------------------------------------------------------------------- --- | Load and transform a module. +--------------------------------------------------------------------------------------------------- +-- | Load and transform source code, interface, or build file. +-- -- The result is printed to @stdout@. --- Any errors are thrown in the `ErrorT` monad. +-- Any errors are thrown in the `ExceptT` monad. -- -- This function handle fragments of Disciple Core, as well as Source Tetra -- modules. The language to use is determined by inspecting the file name @@ -37,19 +47,50 @@ -- -- We also take the specification of a simplifier to apply to the module. -- +-- For Source Tetra modules, dependent modules will be compiled, +-- or their interfaces loaded as needed. +-- cmdLoadFromFile :: Config -- ^ Driver config. + -> Store -- ^ Interface store. -> Maybe String -- ^ Simplifier specification. -> [FilePath] -- ^ More modules to use as inliner templates. -> FilePath -- ^ Module file name. - -> ErrorT String IO () + -> ExceptT String IO () -cmdLoadFromFile config mStrSimpl fsTemplates filePath +cmdLoadFromFile config store mStrSimpl fsTemplates filePath + -- Load build file. + | ".build" <- takeExtension filePath + = do + str <- liftIO $ readFile filePath + case Spec.parseBuildSpec filePath str of + Left err -> throwE $ show err + Right spec -> liftIO $ putStrLn $ show spec + + -- Load an interface file. + | ".di" <- takeExtension filePath + = do + str <- liftIO $ readFile filePath + timeDI <- liftIO $ getModificationTime filePath + case Interface.loadInterface filePath timeDI str of + Left err -> throwE $ renderIndent $ ppr err + Right interface -> liftIO $ putStrLn $ renderIndent $ ppr interface + -- Load a Disciple Source Tetra module. - | ".dst" <- takeExtension filePath - = cmdLoadSourceTetraFromFile config filePath + | ".ds" <- takeExtension filePath + = case mStrSimpl of + Nothing + -> do cmdLoadSourceTetraFromFile config store Tetra.bundle filePath + Just strSimpl + -> do -- Parse the specified simplifier. + bundle' <- cmdLoadSimplifierIntoBundle config + Tetra.bundle strSimpl fsTemplates + + -- Load a simplify the target module. + cmdLoadSourceTetraFromFile config store bundle' filePath + -- Load a module in some fragment of Disciple Core. | Just language <- languageOfExtension (takeExtension filePath) = case mStrSimpl of @@ -63,71 +104,83 @@ -- Don't know how to load this file. | otherwise = let ext = takeExtension filePath - in throwError $ "Cannot load '" ++ ext ++ "' files." + in throwE $ "Cannot load '" ++ ext ++ "' files." -------------------------------------------------------------------------------- +--------------------------------------------------------------------------------------------------- -- | Load a Disciple Source Tetra module from a file. -- The result is printed to @stdout@. --- Any errors are thrown in the `ErrorT` monad. +-- Any errors are thrown in the `ExceptT` monad. cmdLoadSourceTetraFromFile - :: Config -- ^ Driver config. - -> FilePath -- ^ Module file path. - -> ErrorT String IO () + :: Config -- ^ Driver config. + -> Store -- ^ Interface store. + -> Bundle Int Tetra.Name Tetra.Error -- ^ Tetra language bundle. + -> FilePath -- ^ Module file path. + -> ExceptT String IO () -cmdLoadSourceTetraFromFile config filePath +cmdLoadSourceTetraFromFile config store bundle filePath = do -- Check that the file exists. exists <- liftIO $ doesFileExist filePath when (not exists) - $ throwError $ "No such file " ++ show filePath + $ throwE $ "No such file " ++ show filePath + -- Call the compiler to build/load all dependent modules. + cmdCompileRecursive config False store filePath + -- Read in the source file. src <- liftIO $ readFile filePath - - cmdLoadSourceTetraFromString config (SourceFile filePath) src + + cmdLoadSourceTetraFromString config store bundle + (SourceFile filePath) src -------------------------------------------------------------------------------- +--------------------------------------------------------------------------------------------------- -- | Load a Disciple Source Tetra module from a string. -- The result is printed to @stdout@. --- Any errors are thrown in the `ErrorT` monad. +-- Any errors are thrown in the `ExceptT` monad. cmdLoadSourceTetraFromString - :: Config -- ^ Driver config. - -> Source -- ^ Source of the code. - -> String -- ^ Program module text. - -> ErrorT String IO () + :: Config -- ^ Driver config. + -> Store -- ^ Interface store. + -> Bundle Int Tetra.Name Tetra.Error -- ^ Tetra language bundle. + -> Source -- ^ Source of the code. + -> String -- ^ Program module text. + -> ExceptT String IO () -cmdLoadSourceTetraFromString config source str +cmdLoadSourceTetraFromString config store bundle source str = let pmode = prettyModeOfConfig $ configPretty config pipeLoad = pipeText (nameOfSource source) (lineStartOfSource source) str - $ stageSourceTetraLoad config source - [ PipeCoreOutput pmode SinkStdout ] + $ stageSourceTetraLoad config source store + [ PipeCoreReannotate (\a -> a { annotTail = () }) + [ PipeCoreSimplify Tetra.fragment (bundleStateInit bundle) + (bundleSimplifier bundle) + [ PipeCoreOutput pmode SinkStdout ]]] + in do errs <- liftIO pipeLoad case errs of [] -> return () - es -> throwError $ renderIndent $ vcat $ map ppr es + es -> throwE $ renderIndent $ vcat $ map ppr es -------------------------------------------------------------------------------- +--------------------------------------------------------------------------------------------------- -- | Load a Disciple Core module from a file. -- The result is printed to @stdout@. cmdLoadCoreFromFile :: Config -- ^ Driver config. -> Language -- ^ Core language definition. -> FilePath -- ^ Module file path - -> ErrorT String IO () + -> ExceptT String IO () cmdLoadCoreFromFile config language filePath = do -- Check that the file exists. exists <- liftIO $ doesFileExist filePath when (not exists) - $ throwError $ "No such file " ++ show filePath + $ throwE $ "No such file " ++ show filePath -- Read in the source file. src <- liftIO $ readFile filePath @@ -135,7 +188,7 @@ cmdLoadCoreFromString config language (SourceFile filePath) src -------------------------------------------------------------------------------- +--------------------------------------------------------------------------------------------------- -- | Load a Disciple Core module from a string. -- The result it printed to @stdout@. cmdLoadCoreFromString @@ -143,7 +196,7 @@ -> Language -- ^ Language definition -> Source -- ^ Source of the code. -> String -- ^ Program module text. - -> ErrorT String IO () + -> ExceptT String IO () cmdLoadCoreFromString config language source str | Language bundle <- language @@ -151,15 +204,10 @@ = let pmode = prettyModeOfConfig $ configPretty config - -- The type inferencer doesn't work with the Lite fragment. - config' = if fragmentExtension fragment == "dcl" - then config { configInferTypes = False} - else config - pipeLoad = pipeText (nameOfSource source) (lineStartOfSource source) str $ PipeTextLoadCore fragment - (if configInferTypes config' then C.Synth else C.Recon) + (if configInferTypes config then C.Synth else C.Recon) SinkDiscard [ PipeCoreReannotate (\a -> a { annotTail = () }) [ PipeCoreSimplify fragment (bundleStateInit bundle) @@ -170,10 +218,10 @@ errs <- liftIO pipeLoad case errs of [] -> return () - es -> throwError $ renderIndent $ vcat $ map ppr es + es -> throwE $ renderIndent $ vcat $ map ppr es -------------------------------------------------------------------------------- +--------------------------------------------------------------------------------------------------- -- | Parse the simplifier defined in this string, -- and load it and all the inliner templates into the language bundle. cmdLoadSimplifier @@ -181,11 +229,26 @@ -> Language -- ^ Language definition. -> String -- ^ Simplifier specification. -> [FilePath] -- ^ Modules to use as inliner templates. - -> ErrorT String IO Language + -> ExceptT String IO Language cmdLoadSimplifier config language strSimpl fsTemplates | Language bundle <- language - , modules_bundle <- bundleModules bundle + = do bundle' <- cmdLoadSimplifierIntoBundle config bundle strSimpl fsTemplates + return $ Language bundle' + + +-- | Parse the simplifier defined in this string, +-- and load it and all the inliner templates into the bundle +cmdLoadSimplifierIntoBundle + :: (Ord n, Show n, NFData n, Pretty n, Pretty (err (AnTEC SourcePos n))) + => Config -- ^ Driver config. + -> Bundle s n err -- ^ Language bundle + -> String -- ^ Simplifier specification. + -> [FilePath] -- ^ Modules to use as inliner templates. + -> ExceptT String IO (Bundle s n err) + +cmdLoadSimplifierIntoBundle config bundle strSimpl fsTemplates + | modules_bundle <- bundleModules bundle , mkNamT <- bundleMakeNamifierT bundle , mkNamX <- bundleMakeNamifierX bundle , rules <- bundleRewriteRules bundle @@ -202,21 +265,17 @@ modules_annot <- case mModules of - Nothing -> throwError $ "Cannot load inlined module." + Nothing -> throwE $ "Cannot load inlined module." Just ms -> return $ ms -- Zap annotations on the loaded modules. -- Any type errors will already have been displayed, so we don't need -- the source position info any more. - let zapAnnot annot - = annot { annotTail = () } - - let modules_new - = map (reannotate zapAnnot) modules_annot + let zapAnnot annot = annot { annotTail = () } + let modules_new = map (reannotate zapAnnot) modules_annot -- Collect all definitions from modules - let modules_all - = Map.elems modules_bundle ++ modules_new + let modules_all = Map.elems modules_bundle ++ modules_new -- Wrap up the inliner templates and current rules into -- a SimplifierDetails, which we give to the Simplifier parser. @@ -227,9 +286,6 @@ -- Parse the simplifer string. case parseSimplifier readName details strSimpl of - Left err - -> throwError $ renderIndent $ ppr err - - Right simpl - -> return $ Language $ bundle { bundleSimplifier = simpl } + Left err -> throwE $ renderIndent $ ppr err + Right simpl -> return $ bundle { bundleSimplifier = simpl } diff --git a/DDC/Driver/Command/Make.hs b/DDC/Driver/Command/Make.hs deleted file mode 100644 --- a/DDC/Driver/Command/Make.hs +++ /dev/null @@ -1,81 +0,0 @@ - -module DDC.Driver.Command.Make - (cmdMake) -where -import DDC.Driver.Stage -import DDC.Interface.Source -import DDC.Build.Pipeline -import System.FilePath -import System.Directory -import Control.Monad.Trans.Error -import Control.Monad.IO.Class -import Control.Monad -import qualified DDC.Core.Pretty as P - - --- | Make a source module into an executable. -cmdMake :: Config -> FilePath -> ErrorT String IO () -cmdMake config filePath - = do - -- Read in the source file. - exists <- liftIO $ doesFileExist filePath - when (not exists) - $ throwError $ "No such file " ++ show filePath - - src <- liftIO $ readFile filePath - let ext = takeExtension filePath - let source = SourceFile filePath - - -- Decide what to do based on file extension. - let make - -- Make a Source Tetra module. - | ext == ".dst" - = liftIO - $ pipeText (nameOfSource source) (lineStartOfSource source) src - $ stageSourceTetraLoad config source - [ PipeCoreReannotate (const ()) - [ stageTetraToSalt config source pipesSalt ]] - - -- Make a Core Tetra module. - | ext == ".dct" - = liftIO - $ pipeText (nameOfSource source) (lineStartOfSource source) src - $ stageTetraLoad config source - [ stageTetraToSalt config source pipesSalt ] - - -- Make a Core Lite module. - | ext == ".dcl" - = liftIO - $ pipeText (nameOfSource source) (lineStartOfSource source) src - $ stageLiteLoad config source - [ stageLiteOpt config source - [ stageLiteToSalt config source pipesSalt ]] - - -- Make a Core Salt module. - | ext == ".dcs" - = liftIO - $ pipeText (nameOfSource source) (lineStartOfSource source) src - $ stageSaltLoad config source pipesSalt - - -- Unrecognised. - | otherwise - = throwError $ "Cannot make '" ++ filePath ++ "' files." - - pipesSalt - = case configViaBackend config of - ViaLLVM - -> [ PipeCoreReannotate (const ()) - [ stageSaltOpt config source - [ stageSaltToLLVM config source - [ stageCompileLLVM config source filePath True ]]]] - - ViaC - -> [ PipeCoreReannotate (const ()) - [ stageSaltOpt config source - [ stageCompileSalt config source filePath True ]]] - - -- Throw any errors that arose during compilation. - errs <- make - case errs of - [] -> return () - es -> throwError $ P.renderIndent $ P.vcat $ map P.ppr es diff --git a/DDC/Driver/Command/Parse.hs b/DDC/Driver/Command/Parse.hs --- a/DDC/Driver/Command/Parse.hs +++ b/DDC/Driver/Command/Parse.hs @@ -14,7 +14,7 @@ import DDC.Core.Lexer as C import DDC.Base.Parser as BP import DDC.Data.Token as Token -import Control.Monad.Trans.Error +import Control.Monad.Trans.Except import Control.Monad.IO.Class import System.FilePath import System.Directory @@ -24,7 +24,7 @@ ------------------------------------------------------------------------------- -- | Parse a module. -- The result AST is printed to @stdout@. --- Any errors are thrown in the `ErrorT` monad. +-- Any errors are thrown in the `ExceptT` monad. -- -- This function handle fragments of Disciple Core, as well as Source Tetra -- modules. The language to use is determined by inspecting the file name @@ -33,12 +33,12 @@ cmdParseFromFile :: Config -- ^ Driver config. -> FilePath -- ^ Module file name. - -> ErrorT String IO () + -> ExceptT String IO () cmdParseFromFile config filePath -- Parse a Disciple Source Tetra module. - | ".dst" <- takeExtension filePath + | ".ds" <- takeExtension filePath = cmdParseSourceTetraFromFile config filePath -- Parse a module in some fragment of Disciple Core. @@ -48,24 +48,24 @@ -- Don't know how to parse this file. | otherwise = let ext = takeExtension filePath - in throwError $ "Cannot parse '" ++ ext ++ "' files." + in throwE $ "Cannot parse '" ++ ext ++ "' files." ------------------------------------------------------------------------------- -- | Parse a Disciple Source Tetra module from a file. -- The result AST is printed to @stdout@. --- Any errors are thrown in the `ErrorT` monad. +-- Any errors are thrown in the `ExceptT` monad. cmdParseSourceTetraFromFile :: Config -- ^ Driver config. -> FilePath -- ^ Module file path. - -> ErrorT String IO () + -> ExceptT String IO () cmdParseSourceTetraFromFile config filePath = do -- Check that the file exists. exists <- liftIO $ doesFileExist filePath when (not exists) - $ throwError $ "No such file " ++ show filePath + $ throwE $ "No such file " ++ show filePath -- Read in the source file. src <- liftIO $ readFile filePath @@ -80,18 +80,12 @@ when (configDump config) $ liftIO $ writeFile "dump.tetra-parse.tokens" $ unlines $ map show $ map Token.tokenTok toks - - let context = ST.Context - { ST.contextTrackedEffects = True - , ST.contextTrackedClosures = True - , ST.contextFunctionalEffects = False - , ST.contextFunctionalClosures = False } case BP.runTokenParser C.describeTok filePath (ST.pModule context) toks of Left err - -> throwError (renderIndent $ ppr err) + -> throwE (renderIndent $ ppr err) Right mm -> liftIO $ putStrLn (renderIndent $ ppr mm) @@ -100,12 +94,12 @@ ------------------------------------------------------------------------------- -- | Parse a Disciple Core module from a file. -- The AST is printed to @stdout@. --- Any errors are thrown in the `ErrorT` monad. +-- Any errors are thrown in the `ExceptT` monad. cmdParseCoreFromFile :: Config -- ^ Driver config -> Language -- ^ Core language definition. -> FilePath -- ^ Module file path. - -> ErrorT String IO () + -> ExceptT String IO () cmdParseCoreFromFile _config language filePath | Language bundle <- language @@ -115,7 +109,7 @@ -- Check that the file exists. exists <- liftIO $ doesFileExist filePath when (not exists) - $ throwError $ "No such file " ++ show filePath + $ throwE $ "No such file " ++ show filePath -- Read in the source file. src <- liftIO $ readFile filePath @@ -127,7 +121,7 @@ C.describeTok filePath (C.pModule (C.contextOfProfile profile)) toks of Left err - -> throwError (renderIndent $ ppr err) + -> throwE (renderIndent $ ppr err) Right mm -> liftIO $ putStrLn (renderIndent $ ppr mm) diff --git a/DDC/Driver/Command/Read.hs b/DDC/Driver/Command/Read.hs --- a/DDC/Driver/Command/Read.hs +++ b/DDC/Driver/Command/Read.hs @@ -3,7 +3,7 @@ ( cmdReadModule , cmdReadModule') where -import DDC.Interface.Source +import DDC.Driver.Interface.Source import DDC.Driver.Config import DDC.Build.Pipeline import DDC.Build.Language @@ -41,11 +41,6 @@ cmdReadModule' printErrors config fragment filePath = do - -- The inferencer doesn't work with the Lite fragment. - let config' = if fragmentExtension fragment == "dcl" - then config { configInferTypes = False } - else config - -- Read in the source file. exists <- doesFileExist filePath when (not exists) @@ -54,7 +49,7 @@ src <- readFile filePath let source = SourceFile filePath - cmdReadModule_parse printErrors config' filePath fragment source src + cmdReadModule_parse printErrors config filePath fragment source src cmdReadModule_parse printErrors config filePath fragment source src diff --git a/DDC/Driver/Command/RewriteRules.hs b/DDC/Driver/Command/RewriteRules.hs --- a/DDC/Driver/Command/RewriteRules.hs +++ b/DDC/Driver/Command/RewriteRules.hs @@ -2,7 +2,7 @@ module DDC.Driver.Command.RewriteRules ( cmdTryReadRules ) where -import DDC.Interface.Source +import DDC.Driver.Interface.Source import DDC.Build.Language import DDC.Core.Fragment import DDC.Core.Simplifier @@ -88,8 +88,8 @@ liftSnd f (x, y) = (x, f y) -- Final kind and type environments - kinds' = kinds `Env.union` kindsImp `Env.union` kindsExp - types' = types `Env.union` typesImp `Env.union` typesExp + kinds' = kinds `Env.union` kindsImp `Env.union` kindsExp + types' = types `Env.union` typesImp `Env.union` typesExp source' = nameOfSource source diff --git a/DDC/Driver/Command/Tetra/Boxing.hs b/DDC/Driver/Command/Tetra/Boxing.hs --- a/DDC/Driver/Command/Tetra/Boxing.hs +++ b/DDC/Driver/Command/Tetra/Boxing.hs @@ -4,23 +4,32 @@ where import DDC.Driver.Stage import DDC.Driver.Config -import DDC.Interface.Source +import DDC.Driver.Interface.Source import DDC.Build.Pipeline -import Control.Monad.Trans.Error +import System.FilePath +import Control.Monad.Trans.Except import Control.Monad.IO.Class import qualified DDC.Core.Check as C import qualified DDC.Base.Pretty as P import qualified DDC.Build.Language.Tetra as Tetra --- | Prepare a Disciple Core Tetra module for lowering. +-- | Manage boxing in a Tetra module. cmdTetraBoxing :: Config -- ^ Driver config. -> Source -- ^ Source of the code. -> String -- ^ Program module text. - -> ErrorT String IO () + -> ExceptT String IO () cmdTetraBoxing config source sourceText + + -- Curring only works for Disciple Core Tetra files. + | SourceFile filePath <- source + , ext <- takeExtension filePath + , ext /= ".dct" + = throwE $ "The Boxing transform only works for Core Tetra (.dct) modules." + + | otherwise = let pmode = prettyModeOfConfig $ configPretty config pipeBoxing @@ -35,6 +44,6 @@ errs <- liftIO pipeBoxing case errs of [] -> return () - es -> throwError $ P.renderIndent $ P.vcat $ map P.ppr es + es -> throwE $ P.renderIndent $ P.vcat $ map P.ppr es diff --git a/DDC/Driver/Command/Tetra/Curry.hs b/DDC/Driver/Command/Tetra/Curry.hs new file mode 100644 --- /dev/null +++ b/DDC/Driver/Command/Tetra/Curry.hs @@ -0,0 +1,51 @@ + +module DDC.Driver.Command.Tetra.Curry + (cmdTetraCurry) +where +import DDC.Driver.Stage +import DDC.Driver.Config +import DDC.Driver.Dump +import DDC.Driver.Interface.Source +import DDC.Build.Pipeline +import Control.Monad.Trans.Except +import Control.Monad.IO.Class +import System.FilePath +import qualified DDC.Core.Check as C +import qualified DDC.Base.Pretty as P +import qualified DDC.Build.Language.Tetra as Tetra + + +-- | Manage higher order functions in a Tetra module. +cmdTetraCurry + :: Config -- ^ Driver config. + -> Source -- ^ Source of the code. + -> String -- ^ Program module text. + -> ExceptT String IO () + +cmdTetraCurry config source sourceText + + -- Curring only works for Disciple Core Tetra files. + | SourceFile filePath <- source + , ext <- takeExtension filePath + , ext /= ".dct" + = throwE $ "The Curry transform only works for Core Tetra (.dct) modules." + + | otherwise + = let pmode = prettyModeOfConfig $ configPretty config + + pipeCurry + = pipeText (nameOfSource source) + (lineStartOfSource source) sourceText + $ PipeTextLoadCore Tetra.fragment C.Recon SinkDiscard + [ PipeCoreAsTetra + [ PipeTetraCurry + [ PipeCoreOutput pmode (dump config source "dump.tetra-curry.dct") + , PipeCoreCheck Tetra.fragment C.Recon SinkDiscard + [ PipeCoreOutput pmode SinkStdout ]]]] + + in do + errs <- liftIO pipeCurry + case errs of + [] -> return () + es -> throwE $ P.renderIndent $ P.vcat $ map P.ppr es + diff --git a/DDC/Driver/Command/ToC.hs b/DDC/Driver/Command/ToC.hs --- a/DDC/Driver/Command/ToC.hs +++ b/DDC/Driver/Command/ToC.hs @@ -6,35 +6,37 @@ , cmdToSeaCoreFromFile , cmdToSeaCoreFromString) where +import DDC.Driver.Command.Compile import DDC.Driver.Stage -import DDC.Interface.Source +import DDC.Driver.Interface.Source import DDC.Build.Pipeline import DDC.Build.Language import DDC.Core.Fragment import DDC.Base.Pretty import System.FilePath import System.Directory -import Control.Monad.Trans.Error +import Control.Monad.Trans.Except import Control.Monad.IO.Class - import Control.Monad +import DDC.Build.Interface.Store (Store) ------------------------------------------------------------------------------- -- | Convert a module to C. -- The output is printed to @stdout@. --- Any errors are thrown in the `ErrorT` monad. +-- Any errors are thrown in the `ExceptT` monad. -- cmdToSeaFromFile :: Config -- ^ Driver config. + -> Store -- ^ Interface store. -> FilePath -- ^ Core language definition. - -> ErrorT String IO () + -> ExceptT String IO () -cmdToSeaFromFile config filePath +cmdToSeaFromFile config store filePath -- Convert a Disciple Source Tetra module. - | ".dst" <- takeExtension filePath - = cmdToSeaSourceTetraFromFile config filePath + | ".ds" <- takeExtension filePath + = cmdToSeaSourceTetraFromFile config store filePath -- Convert a module in some fragment of Disciple Core. | Just language <- languageOfExtension (takeExtension filePath) @@ -43,46 +45,51 @@ -- Don't know how to convert this file. | otherwise = let ext = takeExtension filePath - in throwError $ "Cannot convert '" ++ ext ++ "' files to C." + in throwE $ "Cannot convert '" ++ ext ++ "' files to C." ------------------------------------------------------------------------------- -- | Convert Disciple Source Tetra to C. -- The result is printed to @stdout@. --- Any errors are thrown in the `ErrorT` monad. +-- Any errors are thrown in the `ExceptT` monad. cmdToSeaSourceTetraFromFile :: Config -- ^ Driver config. + -> Store -- ^ Interface store. -> FilePath -- ^ Module file path. - -> ErrorT String IO () + -> ExceptT String IO () -cmdToSeaSourceTetraFromFile config filePath +cmdToSeaSourceTetraFromFile config store filePath = do -- Check that the file exists. exists <- liftIO $ doesFileExist filePath when (not exists) - $ throwError $ "No such file " ++ show filePath + $ throwE $ "No such file " ++ show filePath + -- Call the compiler to build/load all dependent modules. + cmdCompileRecursive config False store filePath + -- Read in the source file. src <- liftIO $ readFile filePath - cmdToSeaSourceTetraFromString config (SourceFile filePath) src + cmdToSeaSourceTetraFromString config store (SourceFile filePath) src ------------------------------------------------------------------------------- -- | Convert Disciple Source Tetra to C. -- The result is printed to @stdout@. --- Any errors are thrown in the `ErrorT` monad. +-- Any errors are thrown in the `ExceptT` monad. cmdToSeaSourceTetraFromString :: Config -- ^ Driver config. + -> Store -- ^ Interface store. -> Source -- ^ Source of the code. -> String -- ^ Program module text. - -> ErrorT String IO () + -> ExceptT String IO () -cmdToSeaSourceTetraFromString config source str +cmdToSeaSourceTetraFromString config store source str = let pipeLoad = pipeText (nameOfSource source) (lineStartOfSource source) str - $ stageSourceTetraLoad config source + $ stageSourceTetraLoad config source store [ PipeCoreReannotate (const ()) [ stageTetraToSalt config source [ stageSaltOpt config source @@ -92,27 +99,27 @@ errs <- liftIO pipeLoad case errs of [] -> return () - es -> throwError $ renderIndent $ vcat $ map ppr es + es -> throwE $ renderIndent $ vcat $ map ppr es ------------------------------------------------------------------------------- -- | Parse, check and convert a Core module to Sea. --- Works for the 'Tetra', 'Lite' and 'Salt' fragments. +-- Works for the 'Tetra', and 'Salt' fragments. -- The result is printed to @stdout@. --- Any errors are thrown in the `ErrorT` monad. +-- Any errors are thrown in the `ExceptT` monad. -- cmdToSeaCoreFromFile :: Config -- ^ Driver config. -> Language -- ^ Core language definition. -> FilePath -- ^ Module file path. - -> ErrorT String IO () + -> ExceptT String IO () cmdToSeaCoreFromFile config language filePath = do -- Check that the file exists. exists <- liftIO $ doesFileExist filePath when (not exists) - $ throwError $ "No such file " ++ show filePath + $ throwE $ "No such file " ++ show filePath -- Read in the source file. src <- liftIO $ readFile filePath @@ -123,14 +130,14 @@ ------------------------------------------------------------------------------- -- | Parse, check, and convert a module to C. -- The output is printed to @stdout@. --- Any errors are thrown in the `ErrorT` monad. +-- Any errors are thrown in the `ExceptT` monad. -- cmdToSeaCoreFromString :: Config -- ^ Compiler configuration. -> Language -- ^ Language definition. -> Source -- ^ Source of the code. -> String -- ^ Program module text. - -> ErrorT String IO () + -> ExceptT String IO () cmdToSeaCoreFromString config language source str | Language bundle <- language @@ -150,17 +157,7 @@ [ stageSaltOpt config source [ stageSaltToC config source SinkStdout]]] - -- Convert a Core Lite module to C. - | fragName == "Lite" - = liftIO - $ pipeText (nameOfSource source) (lineStartOfSource source) str - $ stageLiteLoad config source - [ stageLiteOpt config source - [ stageLiteToSalt config source - [ stageSaltOpt config source - [ stageSaltToC config source SinkStdout]]]] - - -- Convert a Core Lite module to Salt. + -- Convert a Core Salt module to C | fragName == "Salt" = liftIO $ pipeText (nameOfSource source) (lineStartOfSource source) str @@ -170,12 +167,12 @@ -- Unrecognised. | otherwise - = throwError $ "Cannot convert '" ++ fragName ++ "'modules to C." + = throwE $ "Cannot convert '" ++ fragName ++ "'modules to C." -- Throw any errors that arose during compilation errs <- compile case errs of [] -> return () - es -> throwError $ renderIndent $ vcat $ map ppr es + es -> throwE $ renderIndent $ vcat $ map ppr es diff --git a/DDC/Driver/Command/ToLlvm.hs b/DDC/Driver/Command/ToLlvm.hs --- a/DDC/Driver/Command/ToLlvm.hs +++ b/DDC/Driver/Command/ToLlvm.hs @@ -6,34 +6,37 @@ , cmdToLlvmCoreFromFile , cmdToLlvmCoreFromString) where +import DDC.Driver.Command.Compile import DDC.Driver.Stage -import DDC.Interface.Source +import DDC.Driver.Interface.Source import DDC.Build.Pipeline import DDC.Build.Language import DDC.Core.Fragment import DDC.Base.Pretty import System.Directory import System.FilePath -import Control.Monad.Trans.Error +import Control.Monad.Trans.Except import Control.Monad.IO.Class import Control.Monad +import DDC.Build.Interface.Store (Store) ------------------------------------------------------------------------------- -- | Convert a module to LLVM. -- The output is printed to @stdout@. --- Any errors are thrown in the `ErrorT` monad. +-- Any errors are thrown in the `ExceptT` monad. -- cmdToLlvmFromFile :: Config -- ^ Driver config. + -> Store -- ^ Interface store. -> FilePath -- ^ Core language definition. - -> ErrorT String IO () + -> ExceptT String IO () -cmdToLlvmFromFile config filePath +cmdToLlvmFromFile config store filePath -- Convert a Disciple Source Tetra module. - | ".dst" <- takeExtension filePath - = cmdToLlvmSourceTetraFromFile config filePath + | ".ds" <- takeExtension filePath + = cmdToLlvmSourceTetraFromFile config store filePath -- Convert a module in some fragment of Disciple Core. | Just language <- languageOfExtension (takeExtension filePath) @@ -42,46 +45,51 @@ -- Don't know how to convert this file. | otherwise = let ext = takeExtension filePath - in throwError $ "Cannot convert '" ++ ext ++ "' files to LLVM." + in throwE $ "Cannot convert '" ++ ext ++ "' files to LLVM." ------------------------------------------------------------------------------- -- | Convert Disciple Source Tetra to LLVM. -- The result is printed to @stdout@. --- Any errors are thrown in the `ErrorT` monad. +-- Any errors are thrown in the `ExceptT` monad. cmdToLlvmSourceTetraFromFile :: Config -- ^ Driver config. + -> Store -- ^ Interface store. -> FilePath -- ^ Module file path. - -> ErrorT String IO () + -> ExceptT String IO () -cmdToLlvmSourceTetraFromFile config filePath +cmdToLlvmSourceTetraFromFile config store filePath = do -- Check that the file exists. exists <- liftIO $ doesFileExist filePath when (not exists) - $ throwError $ "No such file " ++ show filePath + $ throwE $ "No such file " ++ show filePath + -- Call the compiler to build/load all dependent modules. + cmdCompileRecursive config False store filePath + -- Read in the source file. src <- liftIO $ readFile filePath - cmdToLlvmSourceTetraFromString config (SourceFile filePath) src + cmdToLlvmSourceTetraFromString config store (SourceFile filePath) src ------------------------------------------------------------------------------- -- | Convert Disciple Source Tetra to LLVM. -- The result is printed to @stdout@. --- Any errors are thrown in the `ErrorT` monad. +-- Any errors are thrown in the `ExceptT` monad. cmdToLlvmSourceTetraFromString :: Config -- ^ Driver config. + -> Store -- ^ Interface store. -> Source -- ^ Source of the code. -> String -- ^ Program module text. - -> ErrorT String IO () + -> ExceptT String IO () -cmdToLlvmSourceTetraFromString config source str +cmdToLlvmSourceTetraFromString config store source str = let pipeLoad = pipeText (nameOfSource source) (lineStartOfSource source) str - $ stageSourceTetraLoad config source + $ stageSourceTetraLoad config source store [ PipeCoreReannotate (const ()) [ stageTetraToSalt config source [ stageSaltOpt config source @@ -92,27 +100,27 @@ errs <- liftIO pipeLoad case errs of [] -> return () - es -> throwError $ renderIndent $ vcat $ map ppr es + es -> throwE $ renderIndent $ vcat $ map ppr es ------------------------------------------------------------------------------- -- | Parse, check and convert a Core module to LLVM. --- Works for the 'Tetra', 'Lite' and 'Salt' fragments. +-- Works for the 'Tetra', and 'Salt' fragments. -- The result is printed to @stdout@. --- Any errors are thrown in the `ErrorT` monad. +-- Any errors are thrown in the `ExceptT` monad. -- cmdToLlvmCoreFromFile :: Config -- ^ Driver config. -> Language -- ^ Core language definition. -> FilePath -- ^ Module file path. - -> ErrorT String IO () + -> ExceptT String IO () cmdToLlvmCoreFromFile config language filePath = do -- Check that the file exists. exists <- liftIO $ doesFileExist filePath when (not exists) - $ throwError $ "No such file " ++ show filePath + $ throwE $ "No such file " ++ show filePath -- Read in the source file. src <- liftIO $ readFile filePath @@ -122,16 +130,16 @@ ------------------------------------------------------------------------------- -- | Parse, check and convert a Core module to LLVM. --- Works for the 'Tetra', 'Lite' and 'Salt' fragments. +-- Works for the 'Tetra', and 'Salt' fragments. -- The result is printed to @stdout@. --- Any errors are thrown in the `ErrorT` monad. +-- Any errors are thrown in the `ExceptT` monad. -- cmdToLlvmCoreFromString :: Config -- ^ Driver config. -> Language -- ^ Language definition. -> Source -- ^ Source of the code. -> String -- ^ Program module text. - -> ErrorT String IO () + -> ExceptT String IO () cmdToLlvmCoreFromString config language source str | Language bundle <- language @@ -153,17 +161,6 @@ [ stageSaltToLLVM config source [ PipeLlvmPrint SinkStdout]]]] - -- Convert a Core Lite module to LLVM. - | fragName == "Lite" - = liftIO - $ pipeText (nameOfSource source) (lineStartOfSource source) str - $ stageLiteLoad config source - [ stageLiteOpt config source - [ stageLiteToSalt config source - [ stageSaltOpt config source - [ stageSaltToLLVM config source - [ PipeLlvmPrint SinkStdout]]]]] - -- Convert a Core Salt module to LLVM. | fragName == "Salt" = liftIO @@ -175,10 +172,10 @@ -- Unrecognised. | otherwise - = throwError $ "Cannot convert '" ++ fragName ++ "' modules to LLVM." + = throwE $ "Cannot convert '" ++ fragName ++ "' modules to LLVM." -- Throw any errors that arose during compilation errs <- compile case errs of [] -> return () - es -> throwError $ renderIndent $ vcat $ map ppr es + es -> throwE $ renderIndent $ vcat $ map ppr es diff --git a/DDC/Driver/Command/ToPHP.hs b/DDC/Driver/Command/ToPHP.hs new file mode 100644 --- /dev/null +++ b/DDC/Driver/Command/ToPHP.hs @@ -0,0 +1,170 @@ + +module DDC.Driver.Command.ToPHP + ( cmdToPHPFromFile + , cmdToPHPSourceTetraFromFile + , cmdToPHPSourceTetraFromString + , cmdToPHPCoreFromFile + , cmdToPHPCoreFromString) +where +import DDC.Driver.Stage +import DDC.Driver.Command.Compile +import DDC.Driver.Interface.Source +import DDC.Build.Pipeline +import DDC.Build.Language +import DDC.Core.Fragment +import DDC.Base.Pretty +import System.FilePath +import System.Directory +import Control.Monad.Trans.Except +import Control.Monad.IO.Class +import Control.Monad +import DDC.Build.Interface.Store (Store) +import DDC.Core.Exp.Annot.AnTEC + + +------------------------------------------------------------------------------- +-- | Convert a module to PHP. +-- The output is printed to @stdout@. +-- Any errors are thrown in the `ExceptT` monad. +-- +cmdToPHPFromFile + :: Config -- ^ Driver config. + -> Store -- ^ Interface store. + -> FilePath -- ^ Core language definition. + -> ExceptT String IO () + +cmdToPHPFromFile config store filePath + + -- Convert a Disciple Source Tetra module. + | ".ds" <- takeExtension filePath + = cmdToPHPSourceTetraFromFile config store filePath + + -- Convert a module in some fragment of Disciple Core. + | Just language <- languageOfExtension (takeExtension filePath) + = cmdToPHPCoreFromFile config language filePath + + -- Don't know how to convert this file. + | otherwise + = let ext = takeExtension filePath + in throwE $ "Cannot convert '" ++ ext ++ "' files to PHP." + + +------------------------------------------------------------------------------- +-- | Convert Disciple Source Tetra to PHP. +-- The result is printed to @stdout@. +-- Any errors are thrown in the `ExceptT` monad. +cmdToPHPSourceTetraFromFile + :: Config -- ^ Driver config. + -> Store -- ^ Interface store. + -> FilePath -- ^ Module file path. + -> ExceptT String IO () + +cmdToPHPSourceTetraFromFile config store filePath + = do + -- Check that the file exists. + exists <- liftIO $ doesFileExist filePath + when (not exists) + $ throwE $ "No such file " ++ show filePath + + -- Call the compiler to build/load all dependent modules. + cmdCompileRecursive config False store filePath + + -- Read in the source file. + src <- liftIO $ readFile filePath + + cmdToPHPSourceTetraFromString config store (SourceFile filePath) src + + +------------------------------------------------------------------------------- +-- | Convert Disciple Source Tetra to PHP. +-- The result is printed to @stdout@. +-- Any errors are thrown in the `ExceptT` monad. +cmdToPHPSourceTetraFromString + :: Config -- ^ Driver config. + -> Store -- ^ Interface store. + -> Source -- ^ Source of the code. + -> String -- ^ Program module text. + -> ExceptT String IO () + +cmdToPHPSourceTetraFromString config store source str + = let + pipeLoad + = pipeText (nameOfSource source) (lineStartOfSource source) str + $ stageSourceTetraLoad config source store + [ PipeCoreReannotate annotTail + [ PipeCoreAsTetra + [ PipeTetraToPHP SinkStdout ]]] + + in do + errs <- liftIO pipeLoad + case errs of + [] -> return () + es -> throwE $ renderIndent $ vcat $ map ppr es + + +------------------------------------------------------------------------------- +-- | Parse, check and convert a Core module to PHP. +-- Works for the 'Tetra', and 'Salt' fragments. +-- The result is printed to @stdout@. +-- Any errors are thrown in the `ExceptT` monad. +-- +cmdToPHPCoreFromFile + :: Config -- ^ Driver config. + -> Language -- ^ Core language definition. + -> FilePath -- ^ Module file path. + -> ExceptT String IO () + +cmdToPHPCoreFromFile config language filePath + = do + -- Check that the file exists. + exists <- liftIO $ doesFileExist filePath + when (not exists) + $ throwE $ "No such file " ++ show filePath + + -- Read in the source file. + src <- liftIO $ readFile filePath + + cmdToPHPCoreFromString config language (SourceFile filePath) src + + +------------------------------------------------------------------------------- +-- | Parse, check, and convert a module to PHP. +-- The output is printed to @stdout@. +-- Any errors are thrown in the `ExceptT` monad. +-- +cmdToPHPCoreFromString + :: Config -- ^ Compiler configuration. + -> Language -- ^ Language definition. + -> Source -- ^ Source of the code. + -> String -- ^ Program module text. + -> ExceptT String IO () + +cmdToPHPCoreFromString config language source str + | Language bundle <- language + , fragment <- bundleFragment bundle + , profile <- fragmentProfile fragment + = do + let fragName = profileName profile + + -- Decide what to do based on file extension and current fragment. + let compile + -- Convert a Core Tetra module to PHP. + | fragName == "Tetra" + = liftIO + $ pipeText (nameOfSource source) (lineStartOfSource source) str + $ stageTetraLoad config source + [ PipeCoreReannotate (const ()) + [ PipeCoreAsTetra + [ PipeTetraToPHP SinkStdout ]]] + + -- Unrecognised. + | otherwise + = throwE $ "Cannot convert '" ++ fragName ++ "'modules to PHP." + + + -- Throw any errors that arose during compilation + errs <- compile + case errs of + [] -> return () + es -> throwE $ renderIndent $ vcat $ map ppr es + diff --git a/DDC/Driver/Command/ToSalt.hs b/DDC/Driver/Command/ToSalt.hs --- a/DDC/Driver/Command/ToSalt.hs +++ b/DDC/Driver/Command/ToSalt.hs @@ -6,18 +6,20 @@ , cmdToSaltCoreFromFile , cmdToSaltCoreFromString) where +import DDC.Driver.Command.Compile import DDC.Driver.Stage import DDC.Driver.Config -import DDC.Interface.Source +import DDC.Driver.Interface.Source import DDC.Build.Pipeline import DDC.Build.Language import DDC.Core.Fragment import DDC.Base.Pretty import System.FilePath import System.Directory -import Control.Monad.Trans.Error +import Control.Monad.Trans.Except import Control.Monad.IO.Class import Control.Monad +import DDC.Build.Interface.Store (Store) import qualified DDC.Build.Language.Salt as Salt import qualified DDC.Core.Check as C @@ -25,18 +27,18 @@ ------------------------------------------------------------------------------- -- | Convert a module to Core Salt. -- The output is printed to @stdout@. --- Any errors are thrown in the `ErrorT` monad. --- +-- Any errors are thrown in the `ExceptT` monad. cmdToSaltFromFile :: Config -- ^ Driver config. + -> Store -- ^ Interface store. -> FilePath -- ^ Module file path. - -> ErrorT String IO () + -> ExceptT String IO () -cmdToSaltFromFile config filePath +cmdToSaltFromFile config store filePath -- Convert a Disciple Source Tetra module. - | ".dst" <- takeExtension filePath - = cmdToSaltSourceTetraFromFile config filePath + | ".ds" <- takeExtension filePath + = cmdToSaltSourceTetraFromFile config store filePath -- Convert a module in some fragment of Disciple Core. | Just language <- languageOfExtension (takeExtension filePath) @@ -45,49 +47,54 @@ -- Don't know how to convert this file. | otherwise = let ext = takeExtension filePath - in throwError $ "Cannot convert '" ++ ext ++ "' files to Salt." + in throwE $ "Cannot convert '" ++ ext ++ "' files to Salt." ------------------------------------------------------------------------------- -- | Convert Disciple Core Tetra to Disciple Core Salt. -- The result is printed to @stdout@. --- Any errors are thrown in the `ErrorT` monad. +-- Any errors are thrown in the `ExceptT` monad. cmdToSaltSourceTetraFromFile :: Config -- ^ Driver config. + -> Store -- ^ Interface store. -> FilePath -- ^ Module file path. - -> ErrorT String IO () + -> ExceptT String IO () -cmdToSaltSourceTetraFromFile config filePath +cmdToSaltSourceTetraFromFile config store filePath = do -- Check that the file exists. exists <- liftIO $ doesFileExist filePath when (not exists) - $ throwError $ "No such file " ++ show filePath + $ throwE $ "No such file " ++ show filePath + -- Call the compiler to build/load all dependent modules. + cmdCompileRecursive config False store filePath + -- Read in the source file. src <- liftIO $ readFile filePath - cmdToSaltSourceTetraFromString config (SourceFile filePath) src + cmdToSaltSourceTetraFromString config store (SourceFile filePath) src ------------------------------------------------------------------------------- -- | Convert Disciple Source Tetra to Disciple Core Salt. -- The result is printed to @stdout@. --- Any errors are thrown in the `ErrorT` monad. +-- Any errors are thrown in the `ExceptT` monad. cmdToSaltSourceTetraFromString :: Config -- ^ Driver config. + -> Store -- ^ Interface store. -> Source -- ^ Source of the code. -> String -- ^ Program module text. - -> ErrorT String IO () + -> ExceptT String IO () -cmdToSaltSourceTetraFromString config source str +cmdToSaltSourceTetraFromString config store source str = let pmode = prettyModeOfConfig $ configPretty config pipeLoad = pipeText (nameOfSource source) (lineStartOfSource source) str - $ stageSourceTetraLoad config source + $ stageSourceTetraLoad config source store [ PipeCoreReannotate (const ()) [ stageTetraToSalt config source [ stageSaltOpt config source @@ -98,27 +105,26 @@ errs <- liftIO pipeLoad case errs of [] -> return () - es -> throwError $ renderIndent $ vcat $ map ppr es + es -> throwE $ renderIndent $ vcat $ map ppr es ------------------------------------------------------------------------------- -- | Convert some fragment of Disciple Core to Core Salt. --- Works for the 'Lite' and 'Tetra' fragments. +-- Works for the 'Tetra' fragment. -- The result is printed to @stdout@. --- Any errors are thrown in the `ErrorT` monad. --- +-- Any errors are thrown in the `ExceptT` monad. cmdToSaltCoreFromFile :: Config -- ^ Driver config. -> Language -- ^ Core language definition. -> FilePath -- ^ Module file path. - -> ErrorT String IO () + -> ExceptT String IO () cmdToSaltCoreFromFile config language filePath = do -- Check that the file exists. exists <- liftIO $ doesFileExist filePath when (not exists) - $ throwError $ "No such file " ++ show filePath + $ throwE $ "No such file " ++ show filePath -- Read in the source file. src <- liftIO $ readFile filePath @@ -128,16 +134,15 @@ ------------------------------------------------------------------------------- -- | Convert some fragment of Disciple Core to Core Salt. --- Works for the 'Lite' and 'Tetra' fragments. +-- Works for the 'Tetra' fragment. -- The result is printed to @stdout@. --- Any errors are thrown in the `ErrorT` monad. --- +-- Any errors are thrown in the `ExceptT` monad. cmdToSaltCoreFromString :: Config -- ^ Driver config. -> Language -- ^ Language definition. -> Source -- ^ Source of the code. -> String -- ^ Program module text. - -> ErrorT String IO () + -> ExceptT String IO () cmdToSaltCoreFromString config language source str | Language bundle <- language @@ -162,25 +167,14 @@ [ PipeCoreCheck Salt.fragment C.Recon SinkDiscard [ PipeCoreOutput pmode SinkStdout]]]] - -- Convert a Core Lite module to Salt. - | fragName == "Lite" - = liftIO - $ pipeText (nameOfSource source) (lineStartOfSource source) str - $ stageLiteLoad config source - [ stageLiteOpt config source - [ stageLiteToSalt config source - [ stageSaltOpt config source - [ PipeCoreCheck Salt.fragment C.Recon SinkDiscard - [ PipeCoreOutput pmode SinkStdout]]]]] - -- Unrecognised fragment name or file extension. | otherwise - = throwError + = throwE $ "Cannot convert '" ++ fragName ++ "' modules to Salt." -- Throw any errors that arose during compilation errs <- compile case errs of [] -> return () - es -> throwError $ renderIndent $ vcat $ map ppr es + es -> throwE $ renderIndent $ vcat $ map ppr es diff --git a/DDC/Driver/Command/Trans.hs b/DDC/Driver/Command/Trans.hs --- a/DDC/Driver/Command/Trans.hs +++ b/DDC/Driver/Command/Trans.hs @@ -1,33 +1,36 @@ +{-# OPTIONS -Werror #-} + module DDC.Driver.Command.Trans ( cmdTransDetect , cmdTransModule , cmdTransExp , cmdTransExpCont - , transExp) + , transExp) where import DDC.Driver.Config import DDC.Driver.Output import DDC.Driver.Command.Check +import DDC.Driver.Interface.Source import DDC.Build.Language import DDC.Build.Pipeline -import DDC.Interface.Source import DDC.Core.Transform.Reannotate import DDC.Core.Load import DDC.Core.Fragment import DDC.Core.Simplifier -import DDC.Core.Exp -import DDC.Core.Compounds +import DDC.Core.Exp.Annot import DDC.Type.Equiv import DDC.Type.Subsumes import DDC.Base.Pretty +import DDC.Base.Name import DDC.Core.Module import Data.Typeable import Control.Monad -import Control.Monad.Trans.Error +import Control.Monad.Trans.Except import Control.Monad.IO.Class import DDC.Type.Env as Env import qualified DDC.Core.Check as C import qualified Control.Monad.State.Strict as S +import Prelude hiding ((<$>)) -- Detect ----------------------------------------------------------------------------------------- @@ -42,7 +45,7 @@ -> Bool -- ^ Print transform info. -> Source -- ^ Source of the code. -> String -- ^ Input text. - -> ErrorT String IO () + -> ExceptT String IO () cmdTransDetect config language shouldPrintInfo source str @@ -64,7 +67,7 @@ -> Bool -- ^ Print transform info. -> Source -- ^ Source of the code. -> String -- ^ Input text. - -> ErrorT String IO () + -> ExceptT String IO () cmdTransModule config language _shouldPrintInfo source str | Language bundle <- language @@ -88,7 +91,7 @@ errs <- liftIO pipeTrans case errs of [] -> return () - es -> throwError $ renderIndent $ vcat $ map ppr es + es -> throwE $ renderIndent $ vcat $ map ppr es -- Exp -------------------------------------------------------------------------------------------- @@ -100,7 +103,7 @@ -> Bool -- ^ Print transform info. -> Source -- ^ Source of input text. -> String -- ^ Input text. - -> ErrorT String IO () + -> ExceptT String IO () cmdTransExp config language traceTrans source str @@ -140,10 +143,10 @@ tr <- transExp traceTrans profile kenv tenv zero simpl $ reannotate (\a -> a { annotTail = ()}) x - + case tr of - Nothing -> return () - Just x' + Nothing -> return () + Just x' -> do outDocLn $ ppr x' eatExp x' @@ -155,7 +158,7 @@ -- Trans ------------------------------------------------------------------------------------------ -- | Transform an expression, or display errors transExp - :: (Eq n, Ord n, Pretty n, Show n) + :: (Eq n, Ord n, Pretty n, Show n, CompoundName n) => Bool -- ^ Trace transform information. -> Profile n -- ^ Language profile. -> KindEnv n -- ^ Kind Environment. @@ -170,13 +173,12 @@ let annot = annotOfExp xx let t1 = annotType annot let eff1 = annotEffect annot - let clo1 = annotClosure annot -- Apply the simplifier. - let tx = flip S.evalState zero - $ applySimplifierX profile kenv tenv simpl xx + let tx = flip S.evalState zero + $ applySimplifierX profile kenv tenv simpl xx - let x' = reannotate (const ()) $ result tx + let x' = reannotate (const ()) $ result tx when (traceTrans) $ case (resultInfo tx) of @@ -184,12 +186,14 @@ -> outDocLn $ text "* TRANSFORM INFORMATION: " <$> indent 4 (ppr inf) <$> text "" + let config = C.configOfProfile profile + let rr = C.checkExp config kenv tenv Recon C.DemandNone x' + -- Check that the simplifier perserved the type of the expression. - case fst $ C.checkExp (C.configOfProfile profile) kenv tenv x' Recon of - Right (x2, t2, eff2, clo2) + case fst rr of + Right (x2, t2, eff2) | equivT t1 t2 , subsumesT kEffect eff1 eff2 - , subsumesT kClosure clo1 clo2 -> do return (Just x2) | otherwise @@ -199,9 +203,7 @@ , text ":: 1 " <+> ppr t1 , text ":: 2 " <+> ppr t2 , text ":!:1 " <+> ppr eff1 - , text ":!:2 " <+> ppr eff2 - , text ":$:1 " <+> ppr clo1 - , text ":$:2 " <+> ppr clo2 ] + , text ":!:2 " <+> ppr eff2 ] return Nothing Left err diff --git a/DDC/Driver/Config.hs b/DDC/Driver/Config.hs --- a/DDC/Driver/Config.hs +++ b/DDC/Driver/Config.hs @@ -5,31 +5,36 @@ , ConfigPretty (..) , defaultConfigPretty , prettyModeOfConfig + , objectPathOfConfig + , exePathOfConfig - , ViaBackend (..)) + , ViaBackend (..) + , RuntimeLinkStrategy (..)) where import DDC.Build.Builder -import DDC.Core.Simplifier (Simplifier) +import DDC.Core.Simplifier (Simplifier) import DDC.Core.Pretty import DDC.Core.Module - -import qualified DDC.Core.Salt.Runtime as Salt -import qualified DDC.Core.Salt as Salt - -import qualified DDC.Core.Lite as Lite +import System.FilePath +import Data.Maybe +import qualified DDC.Core.Salt.Runtime as Salt +import qualified DDC.Core.Salt as Salt +--------------------------------------------------------------------------------------------------- -- | Configuration for main compiler stages. data Config = Config - { -- | Dump intermediate code. - configDump :: Bool + { -- | Print status to console during builds. + configLogBuild :: Bool + -- | Dump intermediate code. + , configDump :: Bool + -- | Use bidirectional type inference on the input code. , configInferTypes :: Bool -- | Simplifiers to apply to intermediate code - , configSimplLite :: Simplifier Int () Lite.Name , configSimplSalt :: Simplifier Int () Salt.Name -- | Backend code generator to use @@ -38,6 +43,9 @@ -- | Runtime system configuration , configRuntime :: Salt.Config + -- | Linking strategy for the runtime. + , configRuntimeLinkStrategy :: RuntimeLinkStrategy + -- | The builder to use for the target architecture , configBuilder :: Builder @@ -47,6 +55,9 @@ -- | Suppress the #import prelude in C modules , configSuppressHashImports :: Bool + -- | Base directories to look for modules sources during build. + , configModuleBaseDirectories :: [FilePath] + -- | Override output file , configOutputFile :: Maybe FilePath @@ -69,7 +80,7 @@ } --- ConfigPretty --------------------------------------------------------------- +--------------------------------------------------------------------------------------------------- -- | Core language pretty printer configuration. data ConfigPretty = ConfigPretty @@ -126,9 +137,27 @@ modeAlt = PrettyModeAlt { modeAltExp = modeExp } - --- ViaBackend ----------------------------------------------------------------- + +-- | Given the name of a source file, +-- determine the name of the associated object file. +objectPathOfConfig :: Config -> FilePath -> FilePath +objectPathOfConfig config path + = let outputDir = fromMaybe (takeDirectory path) (configOutputDir config) + outputDirBase = dropExtension (replaceDirectory path outputDir) + in outputDirBase ++ ".o" + + +-- | Given the name of a source file, +-- determine the name of an associated executable file. +exePathOfConfig :: Config -> FilePath -> FilePath +exePathOfConfig config path + = let oPath = objectPathOfConfig config path + exePathDefault = dropExtension oPath + in fromMaybe exePathDefault (configOutputFile config) + + +--------------------------------------------------------------------------------------------------- data ViaBackend -- | Compile via the C backend. = ViaC @@ -137,3 +166,12 @@ | ViaLLVM deriving Show + + +data RuntimeLinkStrategy + -- | Use the platform's default strategy. + = LinkDefault + + -- | Link the runtime statically. + | LinkStatic + deriving (Show, Eq) diff --git a/DDC/Driver/Dump.hs b/DDC/Driver/Dump.hs --- a/DDC/Driver/Dump.hs +++ b/DDC/Driver/Dump.hs @@ -3,7 +3,7 @@ (dump) where import DDC.Driver.Config -import DDC.Interface.Source +import DDC.Driver.Interface.Source import DDC.Build.Pipeline import System.FilePath import Data.Maybe diff --git a/DDC/Driver/Interface/Input.hs b/DDC/Driver/Interface/Input.hs new file mode 100644 --- /dev/null +++ b/DDC/Driver/Interface/Input.hs @@ -0,0 +1,189 @@ + +module DDC.Driver.Interface.Input + ( InputInterface (..) + , InputState (..) + , Input (..) + , readInput + , inputLine) +where +import DDC.Driver.Interface.Source +import DDC.Data.ListUtils +import System.Directory +import Data.List +import Data.Char + + +-- InputState ----------------------------------------------------------------- +-- Interpreter input state +data InputState command + = InputState + { -- Function to parse commands. + inputParseCommand :: String -> Maybe (command, String) + + -- Input mode. + , inputMode :: Input + + -- Command that we're still receiving input for, + -- along with the line number it started on. + , inputCommand :: Maybe (Maybe command, Int) + + + -- The current line number in the command stream. + , inputLineNumber :: Int + + -- Accumulation of current input buffer. + , inputAcc :: String } + + +-- InputInterface ------------------------------------------------------------- +-- | What interface is being used. +data InputInterface + -- | Read commands from unix command-line args. + = InputInterfaceArgs + + -- | Read commands interactively from the console. + | InputInterfaceConsole + + -- | Read commands from the file with this name. + | InputInterfaceBatch FilePath + deriving (Eq, Show) + + +-- Input ---------------------------------------------------------------------- +-- | How we're reading the current expression. +data Input + -- | Read input line-by-line, using a backslash at the end of the + -- line to continue to the next. + = InputLine + + -- | Read input as a block terminated by a double semicolon (;;) + | InputBlock + + -- | Read input from a file specified on the prompt + | InputFile FilePath + deriving (Eq, Show) + + +-- | Read the input mode from the front of a string. +readInput :: String -> (Input, String) +readInput ss + | isPrefixOf ".." ss + = (InputBlock, drop 2 ss) + + | isPrefixOf "<" ss + , filePath <- dropWhile isSpace (drop 1 ss) + = (InputFile filePath, drop (length filePath) ss) + + | otherwise + = (InputLine, ss) + +------------------------------------------------------------------------------- +inputLine + :: InputInterface + -> InputState c + -> String + -> IO ( InputState c + , Maybe (Source, Maybe c, String)) + -- Just for complete command. + -- .. then Maybe for the default command. + +inputLine interface inputState chunk + | InputState readCmd mode mCommand lineNumber acc <- inputState + = do + -- If this is the first line then try to read the command and + -- input mode from the front so we know how to continue. + -- If we can't read an explicit command then assume this is + -- an expression to evaluate. + let (cmd, lineStart, (input, rest)) + = case mCommand of + -- We haven't started a command yet. + Nothing + -> case readCmd chunk of + Just (cmd', rest') -> (Just cmd', lineNumber, readInput rest') + Nothing -> (Nothing, lineNumber, (InputLine, chunk)) + + -- We've already started a command, and this is more input for it. + Just (cmd', lineStart') + -> (cmd', lineStart', (mode, chunk)) + + let source + -- We were instructed to read the program from a file. + -- Report this file as the source location, independent + -- of how we were instructed to read it. + | InputFile filePath <- input + = SourceFile filePath + + -- The program was embedded in the command stream. + | otherwise + = case interface of + InputInterfaceArgs -> SourceArgs + InputInterfaceConsole -> SourceConsole lineStart + InputInterfaceBatch file -> SourceBatch file lineStart + + + case input of + -- For line-by-line mode, if the line ends with backslash then keep + -- reading, otherwise run the command. + -- We also convert the backslash to a newline so the source + -- position comes out right in parser error messages. + InputLine + | not $ null rest + , last rest == '\\' + , Just initRest <- takeInit rest + -> return ( inputState + { inputCommand = (Just (cmd, lineStart)) + , inputLineNumber = lineNumber + 1 + , inputAcc = acc ++ initRest ++ "\n" } + , Nothing) + + | otherwise + -> return ( inputState + { inputMode = InputLine + , inputCommand = Nothing + , inputLineNumber = lineNumber + 1 + , inputAcc = [] } + , Just (source, cmd, acc ++ rest)) + + + -- For block mode, if the line ends with ';;' then run the command, + -- otherwise keep reading. + InputBlock + | isSuffixOf ";;" rest + -> do let rest' = take (length rest - 2) rest + return ( inputState + { inputMode = InputLine + , inputCommand = Nothing + , inputLineNumber = lineNumber + 1 + , inputAcc = [] } + , Just (source, cmd, acc ++ rest')) + + | otherwise + -> return ( inputState + { inputMode = input + , inputCommand = Just (cmd, lineStart) + , inputLineNumber = lineNumber + 1 + , inputAcc = acc ++ rest ++ "\n" } + , Nothing) + + -- Read input from a file + InputFile filePath + -> do exists <- doesFileExist filePath + if exists + then do + contents <- readFile filePath + return ( inputState + { inputMode = InputLine + , inputCommand = Nothing + , inputLineNumber = lineNumber + 1 + , inputAcc = [] } + , Just (source, cmd, contents)) + else do + putStrLn "No such file." + return ( inputState + { inputMode = InputLine + , inputCommand = Nothing + , inputLineNumber = lineNumber + 1 + , inputAcc = [] } + , Nothing) + + diff --git a/DDC/Driver/Interface/Source.hs b/DDC/Driver/Interface/Source.hs new file mode 100644 --- /dev/null +++ b/DDC/Driver/Interface/Source.hs @@ -0,0 +1,43 @@ + +module DDC.Driver.Interface.Source + ( Source(..) + , lineStartOfSource + , nameOfSource) +where + +-- | Where some source code was obtained from. +-- +-- This is used when generating error messages. +data Source + -- | Read directly from a file. + = SourceFile FilePath + + -- | Supplied on the command line. + | SourceArgs + + -- | Typed into the console. + | SourceConsole Int + + -- | Part of a @.dcx@ batch file. + | SourceBatch FilePath Int + deriving (Eq, Show) + + +-- | Get the starting source line number to report for this source. +lineStartOfSource :: Source -> Int +lineStartOfSource ss + = case ss of + SourceFile{} -> 1 + SourceArgs{} -> 1 + SourceConsole i -> i + SourceBatch _ i -> i + + +-- | Get the name of a source. +nameOfSource :: Source -> String +nameOfSource ss + = case ss of + SourceFile f -> f + SourceArgs -> "" + SourceConsole{} -> "" + SourceBatch{} -> "" diff --git a/DDC/Driver/Stage.hs b/DDC/Driver/Stage.hs --- a/DDC/Driver/Stage.hs +++ b/DDC/Driver/Stage.hs @@ -9,6 +9,7 @@ module DDC.Driver.Stage ( Config (..) , ViaBackend (..) + , RuntimeLinkStrategy (..) -- * Tetra stages , stageSourceTetraLoad @@ -21,11 +22,7 @@ , stageFlowRate , stageFlowLower , stageFlowWind - - -- * Lite stages - , stageLiteLoad - , stageLiteOpt - , stageLiteToSalt + , stageFlowToTetra -- * Salt stages , stageSaltLoad @@ -40,5 +37,4 @@ import DDC.Driver.Config import DDC.Driver.Stage.Tetra import DDC.Driver.Stage.Flow -import DDC.Driver.Stage.Lite import DDC.Driver.Stage.Salt diff --git a/DDC/Driver/Stage/Flow.hs b/DDC/Driver/Stage/Flow.hs --- a/DDC/Driver/Stage/Flow.hs +++ b/DDC/Driver/Stage/Flow.hs @@ -4,16 +4,18 @@ , stageFlowPrep , stageFlowRate , stageFlowLower - , stageFlowWind) + , stageFlowWind + , stageFlowToTetra) where import DDC.Driver.Dump import DDC.Driver.Config -import DDC.Interface.Source +import DDC.Driver.Interface.Source import DDC.Build.Pipeline import DDC.Base.Pretty import qualified DDC.Core.Check as C import qualified DDC.Core.Flow as Flow import qualified DDC.Build.Language.Flow as Flow +import qualified DDC.Core.Salt as Salt --------------------------------------------------------------------------------------------------- @@ -95,4 +97,19 @@ ( PipeCoreOutput pprDefaultMode (dump config source "dump.flow-wind.dcf") : pipesFlow ) ] + + +--------------------------------------------------------------------------------------------------- +-- | Wind loop primops into tail recursive loops in a Core Flow module. +stageFlowToTetra + :: Config -> Source + -> [PipeCore () Salt.Name] + -> PipeCore (C.AnTEC () Flow.Name) Flow.Name + +stageFlowToTetra config source pipesTetra + = PipeCoreAsFlow + [ PipeFlowToTetra + ( PipeCoreOutput pprDefaultMode + (dump config source "dump.flow-out-tetra.dct") + : pipesTetra ) ] diff --git a/DDC/Driver/Stage/Lite.hs b/DDC/Driver/Stage/Lite.hs deleted file mode 100644 --- a/DDC/Driver/Stage/Lite.hs +++ /dev/null @@ -1,79 +0,0 @@ - -module DDC.Driver.Stage.Lite - ( stageLiteLoad - , stageLiteOpt - , stageLiteToSalt) -where -import DDC.Driver.Dump -import DDC.Driver.Config -import DDC.Interface.Source -import DDC.Build.Builder -import DDC.Build.Pipeline -import DDC.Core.Transform.Namify -import DDC.Base.Pretty -import qualified DDC.Core.Salt.Name as Salt -import qualified DDC.Build.Language.Lite as Lite -import qualified DDC.Core.Lite as Lite -import qualified DDC.Core.Check as C -import qualified DDC.Core.Simplifier.Recipe as S - - ---------------------------------------------------------------------------------------------------- --- | Load and type check Core Lite. -stageLiteLoad - :: Config -> Source - -> [PipeCore () Lite.Name] - -> PipeText Lite.Name Lite.Error - -stageLiteLoad config source pipesLite - = PipeTextLoadCore Lite.fragment - C.Recon (dump config source "dump.lite-check.txt") - [ PipeCoreReannotate (const ()) - ( PipeCoreOutput pprDefaultMode - (dump config source "dump.lite-load.dcl") - : pipesLite ) ] - - ---------------------------------------------------------------------------------------------------- --- | Optimise Core Lite. -stageLiteOpt - :: Config -> Source - -> [PipeCore () Lite.Name] - -> PipeCore () Lite.Name - -stageLiteOpt config source pipes - = PipeCoreSimplify - Lite.fragment - (0 :: Int) - (configSimplLite config) - ( PipeCoreOutput pprDefaultMode - (dump config source "dump.lite-opt.dcl") - : pipes) - - ---------------------------------------------------------------------------------------------------- --- | Convert Core Lite to Core Salt. ---- --- The Lite to Salt transform requires the program to be normalised, --- and have type annotations. -stageLiteToSalt - :: Config -> Source - -> [PipeCore () Salt.Name] - -> PipeCore () Lite.Name - -stageLiteToSalt config source pipesSalt - = PipeCoreSimplify Lite.fragment 0 normalizeLite - [ PipeCoreCheck Lite.fragment C.Recon SinkDiscard - [ PipeCoreOutput pprDefaultMode - (dump config source "dump.lite-normalized.dcl") - , PipeCoreAsLite - [ PipeLiteToSalt (buildSpec $ configBuilder config) - (configRuntime config) - ( PipeCoreOutput pprDefaultMode - (dump config source "dump.salt.dcs") - : pipesSalt)]]] - - where normalizeLite - = S.anormalize - (makeNamifier Lite.freshT) - (makeNamifier Lite.freshX) diff --git a/DDC/Driver/Stage/Salt.hs b/DDC/Driver/Stage/Salt.hs --- a/DDC/Driver/Stage/Salt.hs +++ b/DDC/Driver/Stage/Salt.hs @@ -9,7 +9,7 @@ where import DDC.Driver.Dump import DDC.Driver.Config -import DDC.Interface.Source +import DDC.Driver.Interface.Source import DDC.Build.Builder import DDC.Build.Pipeline import DDC.Core.Transform.Namify @@ -116,12 +116,9 @@ stageCompileSalt config source filePath shouldLinkExe = let -- Decide where to place the build products. - outputDir = fromMaybe (takeDirectory filePath) (configOutputDir config) - outputDirBase = dropExtension (replaceDirectory filePath outputDir) - cPath = outputDirBase ++ ".ddc.c" - oPath = outputDirBase ++ ".o" - exePathDefault = outputDirBase - exePath = fromMaybe exePathDefault (configOutputFile config) + oPath = objectPathOfConfig config filePath + exePath = exePathOfConfig config filePath + cPath = replaceExtension oPath ".ddc.c" in PipeCoreSimplify Salt.fragment 0 normalizeSalt [ PipeCoreCheck Salt.fragment C.Recon SinkDiscard @@ -152,27 +149,24 @@ :: Config -> Source -> FilePath -- ^ Path of original source file. -- Build products are placed into the same dir. - -> Bool -- ^ Should we link this into an executable + -> Maybe [FilePath] -- ^ If True then link with these other .os into an executable. -> PipeLlvm -stageCompileLLVM config _source filePath shouldLinkExe +stageCompileLLVM config _source filePath mOtherExeObjs = let -- Decide where to place the build products. - outputDir = fromMaybe (takeDirectory filePath) (configOutputDir config) - outputDirBase = dropExtension (replaceDirectory filePath outputDir) - llPath = outputDirBase ++ ".ddc.ll" - sPath = outputDirBase ++ ".ddc.s" - oPath = outputDirBase ++ ".o" - exePathDefault = outputDirBase - exePath = fromMaybe exePathDefault (configOutputFile config) + oPath = objectPathOfConfig config filePath + exePath = exePathOfConfig config filePath + llPath = replaceExtension oPath ".ddc.ll" + sPath = replaceExtension oPath ".ddc.s" + in -- Make the pipeline for the final compilation. PipeLlvmCompile { pipeBuilder = configBuilder config , pipeFileLlvm = llPath , pipeFileAsm = sPath , pipeFileObject = oPath - , pipeFileExe = if shouldLinkExe - then Just exePath - else Nothing + , pipeFileExe = if isJust $ mOtherExeObjs then Just exePath else Nothing + , pipeLinkOtherObjects = concat $ maybeToList mOtherExeObjs , pipeKeepLlvmFiles = configKeepLlvmFiles config , pipeKeepAsmFiles = configKeepAsmFiles config } diff --git a/DDC/Driver/Stage/Tetra.hs b/DDC/Driver/Stage/Tetra.hs --- a/DDC/Driver/Stage/Tetra.hs +++ b/DDC/Driver/Stage/Tetra.hs @@ -6,7 +6,8 @@ where import DDC.Driver.Dump import DDC.Driver.Config -import DDC.Interface.Source +import DDC.Driver.Interface.Source +import DDC.Build.Interface.Store (Store) import DDC.Build.Pipeline import DDC.Base.Pretty import qualified DDC.Build.Language.Tetra as BE @@ -23,14 +24,18 @@ -- | Load and type check a Source Tetra module. stageSourceTetraLoad :: Config -> Source + -> Store -> [PipeCore (C.AnTEC BP.SourcePos CE.Name) CE.Name] -> PipeText CE.Name CE.Error -stageSourceTetraLoad config source pipesTetra +stageSourceTetraLoad config source store pipesTetra = PipeTextLoadSourceTetra (dump config source "dump.tetra-load-tokens.txt") - (dump config source "dump.tetra-load-raw.dct") + (dump config source "dump.tetra-load-desugared.dct") + (dump config source "dump.tetra-load-core.dct") + (dump config source "dump.tetra-load-precheck.dct") (dump config source "dump.tetra-load-trace.txt") + store ( PipeCoreOutput pprDefaultMode (dump config source "dump.tetra-load.dct") : pipesTetra ) @@ -66,38 +71,49 @@ -> PipeCore () CE.Name stageTetraToSalt config source pipesSalt - = pipe_norm + = pipe_lambdas where - pipe_norm - = PipeCoreSimplify BE.fragment 0 normalize - [ PipeCoreCheck BE.fragment C.Recon SinkDiscard + pipe_lambdas + = PipeCoreCheck BE.fragment C.Recon SinkDiscard + [ PipeCoreSimplify BE.fragment (0 :: Int) C.lambdas [ PipeCoreOutput pprDefaultMode - (dump config source "dump.tetra-normalized.dct") - , pipe_boxing ]] + (dump config source "dump.tetra-lambdas.dct") + , pipe_curry]] + pipe_curry + = PipeCoreCheck BE.fragment C.Recon SinkDiscard + [ PipeCoreAsTetra + [ PipeTetraCurry + [ PipeCoreOutput pprDefaultMode + (dump config source "dump.tetra-curry.dct") + , pipe_prep ]]] + + pipe_prep + = PipeCoreSimplify BE.fragment 0 normalize + [ pipe_boxing ] + normalize = C.anormalize (C.makeNamifier CE.freshT) (C.makeNamifier CE.freshX) pipe_boxing - = PipeCoreAsTetra + = PipeCoreAsTetra [ PipeTetraBoxing - [ PipeCoreOutput pprDefaultMode - (dump config source "dump.tetra-boxing-raw.dct") - , PipeCoreSimplify BE.fragment 0 normalize - [ PipeCoreOutput pprDefaultMode - (dump config source "dump.tetra-boxing-simp.dct") - , PipeCoreCheck BE.fragment C.Recon SinkDiscard - [ PipeCoreOutput pprDefaultMode - (dump config source "dump.tetra-boxing.dct") - , pipe_toSalt]]]] + [ PipeCoreOutput pprDefaultMode + (dump config source "dump.tetra-boxing-raw.dct") + , PipeCoreSimplify BE.fragment 0 (normalize `mappend` C.flatten) + [ PipeCoreOutput pprDefaultMode + (dump config source "dump.tetra-boxing-simp.dct") + , pipe_toSalt]]] - pipe_toSalt - = PipeCoreAsTetra - [ PipeTetraToSalt (B.buildSpec $ configBuilder config) + + pipe_toSalt + = PipeCoreCheck BE.fragment C.Recon SinkDiscard + [ PipeCoreAsTetra + [ PipeTetraToSalt (B.buildSpec $ configBuilder config) (configRuntime config) - ( PipeCoreOutput pprDefaultMode + ( PipeCoreOutput pprDefaultMode (dump config source "dump.salt.dcs") - : pipesSalt)] - + : pipesSalt)]] + diff --git a/ddc-driver.cabal b/ddc-driver.cabal --- a/ddc-driver.cabal +++ b/ddc-driver.cabal @@ -1,5 +1,5 @@ Name: ddc-driver -Version: 0.4.1.3 +Version: 0.4.2.1 License: MIT License-file: LICENSE Author: The Disciplined Disciple Compiler Strike Force @@ -17,52 +17,59 @@ Library Build-depends: - base >= 4.6 && < 4.8, + base >= 4.6 && < 4.9, process >= 1.1 && < 1.3, - deepseq == 1.3.*, + deepseq >= 1.3 && < 1.5, containers == 0.5.*, - filepath == 1.3.*, - mtl == 2.2.*, + filepath >= 1.3 && < 1.5, + mtl == 2.2.1.*, directory == 1.2.*, transformers == 0.4.*, - ddc-base == 0.4.1.*, - ddc-core == 0.4.1.*, - ddc-core-eval == 0.4.1.*, - ddc-core-simpl == 0.4.1.*, - ddc-core-salt == 0.4.1.*, - ddc-core-llvm == 0.4.1.*, - ddc-core-flow == 0.4.1.*, - ddc-core-tetra == 0.4.1.*, - ddc-source-tetra == 0.4.1.*, - ddc-build == 0.4.1.*, - ddc-interface == 0.4.1.* + time >= 1.4 && < 1.6, + ddc-base == 0.4.2.*, + ddc-core == 0.4.2.*, + ddc-core-simpl == 0.4.2.*, + ddc-core-salt == 0.4.2.*, + ddc-core-llvm == 0.4.2.*, + ddc-core-flow == 0.4.2.*, + ddc-core-tetra == 0.4.2.*, + ddc-source-tetra == 0.4.2.*, + ddc-build == 0.4.2.* Exposed-modules: + DDC.Driver.Build.Locate + DDC.Driver.Build.Main + + DDC.Driver.Interface.Input + DDC.Driver.Interface.Source + DDC.Driver.Command.Flow.Concretize DDC.Driver.Command.Flow.Lower DDC.Driver.Command.Flow.Melt DDC.Driver.Command.Flow.Prep DDC.Driver.Command.Flow.Rate DDC.Driver.Command.Flow.Thread + DDC.Driver.Command.Flow.ToTetra DDC.Driver.Command.Flow.Wind DDC.Driver.Command.Tetra.Boxing + DDC.Driver.Command.Tetra.Curry DDC.Driver.Command.BaseBuild + DDC.Driver.Command.Build DDC.Driver.Command.Check DDC.Driver.Command.Compile DDC.Driver.Command.Load - DDC.Driver.Command.Make DDC.Driver.Command.Parse DDC.Driver.Command.Read DDC.Driver.Command.RewriteRules DDC.Driver.Command.ToC DDC.Driver.Command.ToLlvm + DDC.Driver.Command.ToPHP DDC.Driver.Command.ToSalt DDC.Driver.Command.Trans DDC.Driver.Stage.Flow - DDC.Driver.Stage.Lite DDC.Driver.Stage.Salt DDC.Driver.Stage.Tetra