ddc-driver 0.4.2.2 → 0.4.3.1
raw patch · 30 files changed
+336/−183 lines, 30 filesdep −ddc-basedep ~basedep ~ddc-builddep ~ddc-corePVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies removed: ddc-base
Dependency ranges changed: base, ddc-build, ddc-core, ddc-core-flow, ddc-core-llvm, ddc-core-salt, ddc-core-simpl, ddc-core-tetra, ddc-source-tetra, process, time, transformers
API changes (from Hackage documentation)
- DDC.Driver.Config: objectPathOfConfig :: Config -> FilePath -> FilePath
+ DDC.Driver.Command.Scan: cmdScanFromFile :: Config -> FilePath -> Bool -> ExceptT String IO ()
+ DDC.Driver.Config: objectPathsOfConfig :: Config -> FilePath -> (FilePath, [FilePath])
- DDC.Driver.Command.Check: Synth :: Mode n
+ DDC.Driver.Command.Check: Synth :: [Exists n] -> Mode n
- DDC.Driver.Command.RewriteRules: cmdTryReadRules :: (Ord n, Show n, Pretty n, NFData n) => Fragment n err -> FilePath -> Module () n -> IO (NamedRewriteRules () n)
+ DDC.Driver.Command.RewriteRules: cmdTryReadRules :: (Ord n, Show n, Pretty n) => Fragment n err -> FilePath -> Module () n -> IO (NamedRewriteRules () n)
- DDC.Driver.Command.Trans: transExp :: (Eq n, Ord n, Pretty n, Show n, CompoundName n) => Bool -> Profile n -> KindEnv n -> TypeEnv n -> s -> Simplifier s (AnTEC () n) n -> Exp (AnTEC () n) n -> IO (Maybe (Exp (AnTEC () n) n))
+ DDC.Driver.Command.Trans: transExp :: (Ord n, Pretty n, Show n, CompoundName n) => Bool -> Profile n -> EnvX n -> s -> Simplifier s (AnTEC () n) n -> Exp (AnTEC () n) n -> IO (Maybe (Exp (AnTEC () n) n))
- DDC.Driver.Config: prettyModeOfConfig :: (Eq n, Pretty n) => ConfigPretty -> PrettyMode (Module a n)
+ DDC.Driver.Config: prettyModeOfConfig :: ConfigPretty -> PrettyMode (Module a n)
Files
- DDC/Driver/Command/Build.hs +1/−1
- DDC/Driver/Command/Check.hs +11/−11
- DDC/Driver/Command/Compile.hs +126/−51
- DDC/Driver/Command/Flow/Concretize.hs +1/−1
- DDC/Driver/Command/Flow/Lower.hs +2/−2
- DDC/Driver/Command/Flow/Melt.hs +1/−1
- DDC/Driver/Command/Flow/Prep.hs +1/−1
- DDC/Driver/Command/Flow/Rate.hs +1/−1
- DDC/Driver/Command/Flow/Thread.hs +1/−1
- DDC/Driver/Command/Flow/ToTetra.hs +1/−1
- DDC/Driver/Command/Flow/Wind.hs +1/−1
- DDC/Driver/Command/Load.hs +1/−1
- DDC/Driver/Command/Parse.hs +5/−6
- DDC/Driver/Command/Read.hs +2/−2
- DDC/Driver/Command/RewriteRules.hs +11/−8
- DDC/Driver/Command/Scan.hs +37/−0
- DDC/Driver/Command/Tetra/Boxing.hs +1/−1
- DDC/Driver/Command/Tetra/Curry.hs +4/−3
- DDC/Driver/Command/ToC.hs +1/−1
- DDC/Driver/Command/ToLlvm.hs +2/−1
- DDC/Driver/Command/ToPHP.hs +1/−1
- DDC/Driver/Command/ToSalt.hs +1/−1
- DDC/Driver/Command/Trans.hs +25/−17
- DDC/Driver/Config.hs +35/−13
- DDC/Driver/Output.hs +1/−1
- DDC/Driver/Stage/Flow.hs +2/−2
- DDC/Driver/Stage/Salt.hs +17/−17
- DDC/Driver/Stage/Tetra.hs +23/−17
- LICENSE +1/−1
- ddc-driver.cabal +19/−18
DDC/Driver/Command/Build.hs view
@@ -5,7 +5,7 @@ import DDC.Driver.Config import DDC.Driver.Build.Main import DDC.Driver.Command.Compile-import DDC.Base.Pretty+import DDC.Data.Pretty import DDC.Build.Interface.Store (Store) import Control.Monad.Trans.Except import Control.Monad.IO.Class
DDC/Driver/Command/Check.hs view
@@ -37,16 +37,16 @@ import DDC.Core.Pretty import DDC.Type.Transform.SpreadT import DDC.Type.Universe-import DDC.Type.Equiv+import DDC.Type.Exp.Simple import Control.Monad.Trans.Except import Control.Monad.IO.Class 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.Control.Parser as BP import qualified DDC.Core.Check as C+import qualified DDC.Core.Env.EnvT as EnvT -- Module -----------------------------------------------------------------------------------------@@ -142,7 +142,7 @@ = do mModule <- liftIO $ loadModuleFromFile fragment filePath - $ (if configInferTypes config then C.Synth else C.Recon)+ $ (if configInferTypes config then C.Synth [] else C.Recon) case mModule of (Left err, _ct) -> throwE (renderIndent $ ppr err)@@ -218,7 +218,7 @@ srcLine = lineStartOfSource source goParse toks- = case BP.runTokenParser describeTok (nameOfSource source)+ = case BP.runTokenParser describeToken (nameOfSource source) (do t1 <- pTypeAtom (contextOfProfile profile) t2 <- pTypeAtom (contextOfProfile profile) return (t1, t2))@@ -230,16 +230,16 @@ = do b1 <- checkT t1 b2 <- checkT t2 if b1 && b2 - then outStrLn $ show $ equivT t1 t2 + then outStrLn $ show $ equivT EnvT.empty t1 t2 else return () - config = T.configOfProfile profile+ config = C.configOfProfile profile kenv = profilePrimKinds profile checkT t- = case T.checkSpec config kenv (spreadT kenv t) of- Left err + = case C.checkSpec config (spreadT kenv t) of+ Left (err :: C.Error () n) -> do outDocLn $ ppr err return False @@ -286,7 +286,7 @@ features' = features { featuresPartialPrims = featuresPartialPrims features || permitPartialPrims} profile' = profile { profileFeatures = features' }- fragment' = fragment { fragmentProfile = profile' }+ fragment' = fragment { fragmentProfile = profile' } goLex = goLoad (fragmentLexExp fragment'@@ -343,7 +343,7 @@ -- We don't pass the mode directly because the Mode type is -- also parameterised over the type of names. mode = case checkMode of- True -> Synth+ True -> Synth [] False -> Recon goResult fragment (Just x, Just ct)
DDC/Driver/Command/Compile.hs view
@@ -12,7 +12,6 @@ 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@@ -27,9 +26,8 @@ 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.Control.Parser as BP import qualified DDC.Version as Version import qualified Data.List as List @@ -84,6 +82,12 @@ cmdCompileRecursiveDS config bBuildExe store (filePath:fs) fsBlocked = do +-- liftIO $ putStrLn "\n\n* ENTER"+-- liftIO $ putStr $ unlines+-- [ "File = " ++ show filePath+-- , "Queue = " ++ show (filePath : fs)+-- , "Blocked = " ++ show fsBlocked ]+ -- Check if the requested file exists. exists <- liftIO $ doesFileExist filePath when (not exists)@@ -103,6 +107,11 @@ let missing = filter (\m -> not $ elem m modsNamesHave) $ modNamesNeeded +-- liftIO $ putStr $ unlines+-- [ "Modules Needed = " ++ show modNamesNeeded+-- , "Modules Have = " ++ show modsNamesHave+-- , "Modules Missing = " ++ show missing ]+ case missing of -- We've already got all the interfaces needed by the -- current module.@@ -154,53 +163,107 @@ when (not exists) $ throwE $ "No such file " ++ show filePath - -- Read in the source file.+ -- Read in the source file and get the current timestamp. src <- liftIO $ readFile filePath Just timeDS <- liftIO $ getModificationTimeIfExists filePath - -- Parse just the header of the module to determine what other modules- -- it imports.+ -- 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+ -- Search through the likely paths that might hold a pre-compiled+ -- interface and object file. If we find it then we can reload it,+ -- otherwise we'll need to build the module from source again.+ let search (filePathO : filePathsMoreO)+ = do + -- The .di file for the same module should be next to+ -- any .o file for it.+ let filePathDI = replaceExtension filePathO ".di"++ -- Check if we have a fresh interface and object+ -- at this path.+ fresh <- liftIO + $ interfaceIsFresh+ store timeDS modNamesNeeded filePathO++ -- If we indeed have a fresh interface and object + -- then we can load it directly. Otherwise search the rest + -- of the paths.+ if fresh && not (takeFileName filePath == "Main.ds")+ then do +-- liftIO $ putStrLn "* Loading"+ result <- liftIO $ Store.load filePathDI+ case result of+ Left err -> throwE $ P.renderIndent $ P.ppr err+ Right int -> liftIO $ Store.wrap store int++ else search filePathsMoreO++ -- We're out of places to search for pre-existing interface+ -- files, so build it gain.+ search []+ = do +-- liftIO $ putStrLn "* Compiling"+ cmdCompile config buildExe store filePath++ -- Check the config for where the interface might be.+ -- It'll either be next to the source file or in the auxilliary+ -- output directory if that was specified.+ let (filePathO_output, filePathO_libs) + = objectPathsOfConfig config filePath++ -- Search all the likely places.+ search (filePathO_output : filePathO_libs)+++-- | Look for an interface file in the given directory.+-- If there's one there see if it's fresh enough to reload (True)+-- or whether we need to rebuild it (False).+--+-- 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.+--+interfaceIsFresh+ :: Store -- ^ Current interface store.+ -> UTCTime -- ^ Timestamp on original source file.+ -> [C.ModuleName] -- ^ Names of modules needed by source.+ -> FilePath -- ^ Expected path of object file.+ -> IO Bool++interfaceIsFresh store timeDS modNamesNeeded filePathO+ = do 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+ -- object is fresher than source+ let bFreshO + | Just timeO <- mTimeO, timeDS < timeO = True+ | otherwise = False - -- Interface at least as fresh than all dependencies.- -- See Note: Timestamp accuracy during rebuild.- , and [ Store.metaTimeStamp m <= timeDI + -- interface is fresher than source.+ let bFreshDI+ | Just timeDI <- mTimeDI, timeDS < timeDI = True+ | otherwise = False++ let bFreshDep+ | Just timeDI <- mTimeDI+ = 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+ = False - loadOrCompile+ return $ and [bFreshO, bFreshDI, bFreshDep] ---------------------------------------------------------------------------------------------------@@ -251,6 +314,12 @@ | buildExe = Just $ map (\path -> replaceExtension path "o") pathsDI | otherwise = Nothing + -- Determine directory for build products.+ let (pathO, _) = objectPathsOfConfig config filePath+ let pathDI = replaceExtension pathO ".di"+ liftIO $ createDirectoryIfMissing True (takeDirectory pathO)++ -- 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.@@ -330,8 +399,6 @@ , 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@@ -375,19 +442,24 @@ = 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+ case BP.runTokenParser+ C.describeToken+ filePath SE.pModule tokens of Left err -> throwE $ P.renderIndent $ P.ppr err- Right mm -> return $ SE.moduleImportModules mm+ Right mm + -> do + -- Check that the module name matches the file path where+ -- we found the module. If they don't match then the compilation+ -- driver will go into a loop as it can never load a module+ -- with the name it needs.+ when (not $ C.moduleNameMatchesPath filePath (SE.moduleName mm))+ $ error $ unlines+ [ "Module name does not match file path."+ , " module name = " ++ show (SE.moduleName mm)+ , " file path = " ++ show filePath ] + return $ SE.moduleImportModules mm+ | otherwise = return [] @@ -425,11 +497,14 @@ -- | 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 :: [C.Located (C.Token n)] -> [C.Located (C.Token n)] dropBody toks = go toks- where go [] = []- go (Token { tokenTok = C.KA C.KWhere} : _) = []- go (t : moar) = t : go moar+ where go [] = []++ go (C.Located _ (C.KA (C.KKeyword C.EWhere)) : _)+ = []++ go (t : moar) = t : go moar -- [Note: Timestamp acccuracy during rebuild]
DDC/Driver/Command/Flow/Concretize.hs view
@@ -12,7 +12,7 @@ import Control.Monad.IO.Class import qualified DDC.Core.Flow.Transform.Concretize as Concretize import qualified DDC.Core.Check as C-import qualified DDC.Base.Pretty as P+import qualified DDC.Data.Pretty as P -- | Concretize rate variables to loop indices.
DDC/Driver/Command/Flow/Lower.hs view
@@ -8,10 +8,10 @@ import DDC.Build.Pipeline 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.Check as C import qualified DDC.Core.Flow as Flow+import qualified DDC.Data.Pretty as P -- | Lower a flow program to loop code.
DDC/Driver/Command/Flow/Melt.hs view
@@ -10,7 +10,7 @@ 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.Data.Pretty as P -- | Thread a state token through the given flow program.
DDC/Driver/Command/Flow/Prep.hs view
@@ -9,7 +9,7 @@ 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.Data.Pretty as P import qualified DDC.Build.Language.Flow as Flow
DDC/Driver/Command/Flow/Rate.hs view
@@ -9,7 +9,7 @@ import DDC.Build.Pipeline import Control.Monad.Trans.Except import Control.Monad.IO.Class-import qualified DDC.Base.Pretty as P+import qualified DDC.Data.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
DDC/Driver/Command/Flow/Thread.hs view
@@ -14,7 +14,7 @@ import qualified DDC.Core.Transform.Thread as Thread import qualified DDC.Core.Flow.Transform.Thread as Flow import qualified DDC.Core.Check as C-import qualified DDC.Base.Pretty as P+import qualified DDC.Data.Pretty as P -- | Thread a state token through the given flow program.
DDC/Driver/Command/Flow/ToTetra.hs view
@@ -11,7 +11,7 @@ import DDC.Build.Pipeline import DDC.Build.Language import DDC.Core.Fragment-import DDC.Base.Pretty+import DDC.Data.Pretty import System.FilePath import System.Directory import Control.Monad.Trans.Except
DDC/Driver/Command/Flow/Wind.hs view
@@ -8,7 +8,7 @@ import DDC.Build.Pipeline import Control.Monad.Trans.Except import Control.Monad.IO.Class-import qualified DDC.Base.Pretty as P+import qualified DDC.Data.Pretty as P import qualified DDC.Core.Check as C import qualified DDC.Build.Language.Flow as Flow
DDC/Driver/Command/Load.hs view
@@ -207,7 +207,7 @@ 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)
DDC/Driver/Command/Parse.hs view
@@ -12,13 +12,13 @@ import DDC.Core.Fragment as C import DDC.Core.Parser as C import DDC.Core.Lexer as C-import DDC.Base.Parser as BP-import DDC.Data.Token as Token+import DDC.Control.Parser as BP import Control.Monad.Trans.Except import Control.Monad.IO.Class import System.FilePath import System.Directory import Control.Monad+import qualified DDC.Data.SourcePos as SP -------------------------------------------------------------------------------@@ -79,11 +79,10 @@ when (configDump config) $ liftIO $ writeFile "dump.tetra-parse.tokens" - $ unlines $ map show $ map Token.tokenTok toks+ $ unlines $ map show $ map SP.valueOfLocated toks case BP.runTokenParser- C.describeTok filePath - (ST.pModule context) toks of+ C.describeToken filePath ST.pModule toks of Left err -> throwE (renderIndent $ ppr err) @@ -118,7 +117,7 @@ let toks = (C.fragmentLexModule fragment) filePath 1 src case BP.runTokenParser- C.describeTok filePath + C.describeToken filePath (C.pModule (C.contextOfProfile profile)) toks of Left err -> throwE (renderIndent $ ppr err)
DDC/Driver/Command/Read.hs view
@@ -16,7 +16,7 @@ import Data.IORef import System.Directory import System.IO-import qualified DDC.Base.Parser as BP+import qualified DDC.Control.Parser as BP import qualified DDC.Core.Check as C @@ -56,7 +56,7 @@ = do ref <- newIORef Nothing errs <- pipeText (nameOfSource source) (lineStartOfSource source) src $ PipeTextLoadCore fragment- (if configInferTypes config then C.Synth else C.Recon)+ (if configInferTypes config then C.Synth [] else C.Recon) SinkDiscard [ PipeCoreHacks (Canned (\m -> writeIORef ref (Just m) >> return m)) [PipeCoreOutput pprDefaultMode SinkDiscard] ]
DDC/Driver/Command/RewriteRules.hs view
@@ -13,20 +13,20 @@ import DDC.Core.Transform.Reannotate import DDC.Core.Transform.Rewrite.Rule hiding (Error) import DDC.Core.Transform.Rewrite.Parser-import Control.DeepSeq import System.Directory import System.IO-import qualified DDC.Base.Parser as BP+import qualified DDC.Control.Parser as BP import qualified DDC.Core.Check as C import qualified DDC.Core.Parser as C import qualified DDC.Type.Env as Env+import qualified DDC.Core.Env.EnvX as EnvX -- Read rewrite rules --------------------------------------------------------- -- | Load and typecheck a module's rewrite rules, using exported and imported -- definitions from module cmdTryReadRules - :: (Ord n, Show n, Pretty n, NFData n)+ :: (Ord n, Show n, Pretty n) => Fragment n err -- ^ Language fragment. -> FilePath -- ^ Path to the module. -> Module () n -- ^ Module with types of imports and exports@@ -56,7 +56,7 @@ parse fragment modu source str- = case BP.runTokenParser describeTok source' + = case BP.runTokenParser describeToken source' (pRuleMany (C.contextOfProfile (fragmentProfile fragment))) (fragmentLexExp fragment source' 0 str) of Left err -> Left $ renderIndent $ ppr err@@ -67,12 +67,14 @@ where -- Typecheck, then clear annotations check' (n,r)- = do r' <- checkRewriteRule config kinds' types' r+ = do r' <- checkRewriteRule config env' r return (show n, reannotate (const ()) r') - config = C.configOfProfile (fragmentProfile fragment)- kinds = profilePrimKinds (fragmentProfile fragment)- types = profilePrimTypes (fragmentProfile fragment)+ profile = fragmentProfile fragment+ config = C.configOfProfile profile+ kinds = profilePrimKinds profile+ types = profilePrimTypes profile+ defs = profilePrimDataDefs profile kindsImp = moduleKindEnv modu typesImp = moduleTypeEnv modu@@ -90,6 +92,7 @@ -- Final kind and type environments kinds' = kinds `Env.union` kindsImp `Env.union` kindsExp types' = types `Env.union` typesImp `Env.union` typesExp+ env' = EnvX.fromPrimEnvs kinds' types' defs source' = nameOfSource source
+ DDC/Driver/Command/Scan.hs view
@@ -0,0 +1,37 @@+module DDC.Driver.Command.Scan+ ( cmdScanFromFile)+where+import DDC.Driver.Stage+import DDC.Source.Tetra.Lexer as ST+import Control.Monad.Trans.Except+import Control.Monad.IO.Class+import System.Directory+import Control.Monad+import qualified DDC.Data.SourcePos as SP++-------------------------------------------------------------------------------+-- | Scan a module.+-- Any errors are thrown in the `ExceptT` monad.+cmdScanFromFile + :: Config -- ^ Driver config.+ -> FilePath -- ^ Module file name.+ -> Bool -- ^ Whether to print source locations.+ -> ExceptT String IO ()++cmdScanFromFile _config filePath bPrintLocs+ = 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++ -- Lex the source string.+ let toks = ST.lexModuleString filePath 1 src++ if bPrintLocs + then liftIO $ putStr $ unlines $ map show toks+ else liftIO $ putStr $ unlines $ map show $ map SP.valueOfLocated toks+
DDC/Driver/Command/Tetra/Boxing.hs view
@@ -10,7 +10,7 @@ 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.Data.Pretty as P import qualified DDC.Build.Language.Tetra as Tetra
DDC/Driver/Command/Tetra/Curry.hs view
@@ -11,7 +11,7 @@ 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.Data.Pretty as P import qualified DDC.Build.Language.Tetra as Tetra @@ -38,8 +38,9 @@ (lineStartOfSource source) sourceText $ PipeTextLoadCore Tetra.fragment C.Recon SinkDiscard [ PipeCoreAsTetra- [ PipeTetraCurry- [ PipeCoreOutput pmode (dump config source "dump.tetra-curry.dct")+ [ PipeTetraCurry (dump config source "dump.tetra-unshare.dct") + [ PipeCoreOutput pmode + (dump config source "dump.tetra-curry.dct") , PipeCoreCheck Tetra.fragment C.Recon SinkDiscard [ PipeCoreOutput pmode SinkStdout ]]]]
DDC/Driver/Command/ToC.hs view
@@ -12,7 +12,7 @@ import DDC.Build.Pipeline import DDC.Build.Language import DDC.Core.Fragment-import DDC.Base.Pretty+import DDC.Data.Pretty import System.FilePath import System.Directory import Control.Monad.Trans.Except
DDC/Driver/Command/ToLlvm.hs view
@@ -12,7 +12,7 @@ import DDC.Build.Pipeline import DDC.Build.Language import DDC.Core.Fragment-import DDC.Base.Pretty+import DDC.Data.Pretty import System.Directory import System.FilePath import Control.Monad.Trans.Except@@ -179,3 +179,4 @@ case errs of [] -> return () es -> throwE $ renderIndent $ vcat $ map ppr es+
DDC/Driver/Command/ToPHP.hs view
@@ -12,7 +12,7 @@ import DDC.Build.Pipeline import DDC.Build.Language import DDC.Core.Fragment-import DDC.Base.Pretty+import DDC.Data.Pretty import System.FilePath import System.Directory import Control.Monad.Trans.Except
DDC/Driver/Command/ToSalt.hs view
@@ -13,7 +13,7 @@ import DDC.Build.Pipeline import DDC.Build.Language import DDC.Core.Fragment-import DDC.Base.Pretty+import DDC.Data.Pretty import System.FilePath import System.Directory import Control.Monad.Trans.Except
DDC/Driver/Command/Trans.hs view
@@ -17,19 +17,20 @@ import DDC.Core.Load import DDC.Core.Fragment import DDC.Core.Simplifier-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 DDC.Core.Exp.Annot+import DDC.Type.Exp.Simple+import DDC.Data.Pretty+import DDC.Data.Name import Data.Typeable import Control.Monad import Control.Monad.Trans.Except import Control.Monad.IO.Class-import DDC.Type.Env as Env+import DDC.Core.Env.EnvX (EnvX) import qualified DDC.Core.Check as C import qualified Control.Monad.State.Strict as S+import qualified Data.Map.Strict as Map+import qualified DDC.Core.Env.EnvX as EnvX import Prelude hiding ((<$>)) @@ -80,7 +81,7 @@ pipeTrans = 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 zero simpl@@ -138,10 +139,14 @@ where -- Expression is well-typed. goStore profile modules zero simpl (Just x, _)- = do let kenv = modulesExportTypes modules (profilePrimKinds profile)- let tenv = modulesExportValues modules (profilePrimTypes profile)+ = do + let env = modulesEnvX + (profilePrimKinds profile)+ (profilePrimTypes profile)+ (profilePrimDataDefs profile)+ (Map.elems modules) - tr <- transExp traceTrans profile kenv tenv zero simpl + tr <- transExp traceTrans profile env zero simpl $ reannotate (\a -> a { annotTail = ()}) x case tr of@@ -158,22 +163,25 @@ -- Trans ------------------------------------------------------------------------------------------ -- | Transform an expression, or display errors transExp- :: (Eq n, Ord n, Pretty n, Show n, CompoundName n)+ :: (Ord n, Pretty n, Show n, CompoundName n) => Bool -- ^ Trace transform information. -> Profile n -- ^ Language profile.- -> KindEnv n -- ^ Kind Environment.- -> TypeEnv n -- ^ Type Environment.+ -> EnvX n -> s -> Simplifier s (AnTEC () n) n -> Exp (AnTEC () n) n -> IO (Maybe (Exp (AnTEC () n) n)) -transExp traceTrans profile kenv tenv zero simpl xx+transExp traceTrans profile env zero simpl xx = do let annot = annotOfExp xx let t1 = annotType annot let eff1 = annotEffect annot + let kenv = EnvX.kindEnvOfEnvX env+ let tenv = EnvX.typeEnvOfEnvX env+ let envt = EnvX.envxEnvT env+ -- Apply the simplifier. let tx = flip S.evalState zero $ applySimplifierX profile kenv tenv simpl xx@@ -187,13 +195,13 @@ $ text "* TRANSFORM INFORMATION: " <$> indent 4 (ppr inf) <$> text "" let config = C.configOfProfile profile- let rr = C.checkExp config kenv tenv Recon C.DemandNone x' + let rr = C.checkExp config env Recon C.DemandNone x' -- Check that the simplifier perserved the type of the expression. case fst rr of Right (x2, t2, eff2)- | equivT t1 t2- , subsumesT kEffect eff1 eff2+ | equivT envt t1 t2+ , subsumesT envt kEffect eff1 eff2 -> do return (Just x2) | otherwise
DDC/Driver/Config.hs view
@@ -5,7 +5,7 @@ , ConfigPretty (..) , defaultConfigPretty , prettyModeOfConfig- , objectPathOfConfig+ , objectPathsOfConfig , exePathOfConfig , ViaBackend (..)@@ -13,7 +13,7 @@ where import DDC.Build.Builder import DDC.Core.Simplifier (Simplifier)-import DDC.Core.Pretty+import DDC.Core.Pretty hiding ((</>)) import DDC.Core.Module import System.FilePath import Data.Maybe@@ -109,8 +109,7 @@ -- former can be non-recursive with other types, and does not need to be -- parameterised by the annotation or name types. prettyModeOfConfig- :: (Eq n, Pretty n) - => ConfigPretty -> PrettyMode (Module a n)+ :: ConfigPretty -> PrettyMode (Module a n) prettyModeOfConfig config = modeModule@@ -140,21 +139,44 @@ -- | 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"+-- determine the where the object files should go.+--+-- The first component of the result is where we should put produced object files,+-- The second are paths of where we might find pre-existing objects, +-- in preference order. +objectPathsOfConfig + :: Config -- ^ Compiler config.+ -> FilePath -- ^ Path to module source.+ -> (FilePath, [FilePath]) +objectPathsOfConfig config pathSource+ | Just dirOutput <- configOutputDir config+ , takeFileName pathSource == "Main.ds"+ = (dirOutput </> "Main.ds", [])++ | Just dirOutput <- configOutputDir config+ = let oFileSource = replaceExtension pathSource ".o"+ oFileOverride = dirOutput </> replaceExtension pathSource ".o"+ in (oFileOverride, [oFileSource])++ | otherwise+ = let oFileSource = replaceExtension pathSource ".o"+ in (oFileSource, [])++ -- | Given the name of a source file,--- determine the name of an associated executable file.-exePathOfConfig :: Config -> FilePath -> FilePath+-- determine where we should put an executable built from it.+exePathOfConfig + :: Config -- ^ Compiler config.+ -> FilePath -- ^ Path to module source.+ -> FilePath+ exePathOfConfig config path- = let oPath = objectPathOfConfig config path+ = let (oPath, _) = objectPathsOfConfig config path exePathDefault = dropExtension oPath in fromMaybe exePathDefault (configOutputFile config)+ ---------------------------------------------------------------------------------------------------
DDC/Driver/Output.hs view
@@ -4,7 +4,7 @@ , outStr, outStrLn , chatStrLn) where-import DDC.Base.Pretty+import DDC.Data.Pretty -- | Output a document to the console.
DDC/Driver/Stage/Flow.hs view
@@ -11,7 +11,7 @@ import DDC.Driver.Config import DDC.Driver.Interface.Source import DDC.Build.Pipeline-import DDC.Base.Pretty+import DDC.Data.Pretty import qualified DDC.Core.Check as C import qualified DDC.Core.Flow as Flow import qualified DDC.Build.Language.Flow as Flow@@ -27,7 +27,7 @@ stageFlowLoad config source pipesFlow = PipeTextLoadCore Flow.fragment - (if configInferTypes config then C.Synth else C.Recon)+ (if configInferTypes config then C.Synth [] else C.Recon) (dump config source "dump.flow-check.txt") [ PipeCoreReannotate (const ()) ( PipeCoreOutput pprDefaultMode
DDC/Driver/Stage/Salt.hs view
@@ -13,7 +13,7 @@ import DDC.Build.Builder import DDC.Build.Pipeline import DDC.Core.Transform.Namify-import DDC.Base.Pretty+import DDC.Data.Pretty import System.FilePath import Data.Maybe import qualified DDC.Build.Language.Salt as Salt@@ -32,11 +32,11 @@ stageSaltLoad config source pipesSalt = PipeTextLoadCore Salt.fragment - (if configInferTypes config then C.Synth else C.Recon)+ (if configInferTypes config then C.Synth [] else C.Recon) SinkDiscard [ PipeCoreReannotate (const ()) ( PipeCoreOutput pprDefaultMode- (dump config source "dump.salt-load.dcl")+ (dump config source "dump.0-salt-00-load.dcl") : pipesSalt ) ] @@ -53,7 +53,7 @@ (0 :: Int) (configSimplSalt config) ( PipeCoreOutput pprDefaultMode - (dump config source "dump.salt-opt.dcl")+ (dump config source "dump.2-salt-01-opt.dcs") : pipes ) @@ -68,10 +68,10 @@ = PipeCoreSimplify Salt.fragment 0 normalizeSalt [ PipeCoreCheck Salt.fragment C.Recon SinkDiscard [ PipeCoreOutput pprDefaultMode- (dump config source "dump.salt-normalized.dcs")+ (dump config source "dump.2-salt-03-normalized.dcs") , PipeCoreAsSalt [ PipeSaltTransfer- [ PipeSaltOutput (dump config source "dump.salt-transfer.dcs")+ [ PipeSaltOutput (dump config source "dump.2-salt-04-transfer.dcs") , PipeSaltPrint (not $ configSuppressHashImports config) (buildSpec $ configBuilder config)@@ -93,10 +93,10 @@ = PipeCoreSimplify Salt.fragment 0 normalizeSalt [ PipeCoreCheck Salt.fragment C.Recon SinkDiscard [ PipeCoreOutput pprDefaultMode- (dump config source "dump.salt-normalized.dcs")+ (dump config source "dump.2-salt-03-normalized.dcs") , PipeCoreAsSalt [ PipeSaltTransfer- [ PipeSaltOutput (dump config source "dump.salt-transfer.dcs")+ [ PipeSaltOutput (dump config source "dump.2-salt-04-transfer.dcs") , PipeSaltToLlvm (buildSpec $ configBuilder config) pipesLLVM ]]]] @@ -116,17 +116,17 @@ stageCompileSalt config source filePath shouldLinkExe = let -- Decide where to place the build products.- oPath = objectPathOfConfig config filePath- exePath = exePathOfConfig config filePath- cPath = replaceExtension oPath ".ddc.c"+ (oPath, _) = objectPathsOfConfig config filePath+ exePath = exePathOfConfig config filePath+ cPath = replaceExtension oPath ".ddc.c" in PipeCoreSimplify Salt.fragment 0 normalizeSalt [ PipeCoreCheck Salt.fragment C.Recon SinkDiscard [ PipeCoreOutput pprDefaultMode- (dump config source "dump.salt-normalized.dcs")+ (dump config source "dump.2-salt-03-normalized.dcs") , PipeCoreAsSalt [ PipeSaltTransfer- [ PipeSaltOutput (dump config source "dump.salt-transfer.dcs")+ [ PipeSaltOutput (dump config source "dump.2-salt-04-transfer.dcs") , PipeSaltCompile (buildSpec $ configBuilder config) (configBuilder config)@@ -154,10 +154,10 @@ stageCompileLLVM config _source filePath mOtherExeObjs = let -- Decide where to place the build products.- oPath = objectPathOfConfig config filePath- exePath = exePathOfConfig config filePath- llPath = replaceExtension oPath ".ddc.ll"- sPath = replaceExtension oPath ".ddc.s"+ (oPath, _) = objectPathsOfConfig 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
DDC/Driver/Stage/Tetra.hs view
@@ -9,7 +9,7 @@ import DDC.Driver.Interface.Source import DDC.Build.Interface.Store (Store) import DDC.Build.Pipeline-import DDC.Base.Pretty+import DDC.Data.Pretty import qualified DDC.Build.Language.Tetra as BE import qualified DDC.Build.Builder as B import qualified DDC.Core.Tetra as CE@@ -17,7 +17,7 @@ import qualified DDC.Core.Check as C import qualified DDC.Core.Simplifier.Recipe as C import qualified DDC.Core.Transform.Namify as C-import qualified DDC.Base.Parser as BP+import qualified DDC.Control.Parser as BP ---------------------------------------------------------------------------------------------------@@ -30,14 +30,20 @@ stageSourceTetraLoad config source store pipesTetra = PipeTextLoadSourceTetra- (dump config source "dump.tetra-load-tokens.txt")- (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")+ (dump config source "dump.0-source-01-tokens.txt")+ (dump config source "dump.0-source-02-parsed.dst")+ (dump config source "dump.0-source-03-fresh.dst")+ (dump config source "dump.0-source-04-defix.dst")+ (dump config source "dump.0-source-05-expand.dst")+ (dump config source "dump.0-source-06-guards.dst")+ (dump config source "dump.0-source-07-matches.dst")+ (dump config source "dump.0-source-08-prep.dst")+ (dump config source "dump.0-source-09-core.dct")+ (dump config source "dump.0-source-10-precheck.dct")+ (dump config source "dump.0-source-11-trace.txt") store ( PipeCoreOutput pprDefaultMode- (dump config source "dump.tetra-load.dct")+ (dump config source "dump.1-tetra-00-checked.dct") : pipesTetra ) @@ -50,11 +56,11 @@ stageTetraLoad config source pipesTetra = PipeTextLoadCore BE.fragment - (if configInferTypes config then C.Synth else C.Recon)- (dump config source "dump.tetra-check.dct")+ (if configInferTypes config then C.Synth [] else C.Recon)+ (dump config source "dump.1-tetra-00-check.dct") [ PipeCoreReannotate (const ()) ( PipeCoreOutput pprDefaultMode- (dump config source "dump.tetra-load.dct")+ (dump config source "dump.1-tetra-01-load.dct") : pipesTetra ) ] @@ -77,15 +83,15 @@ = PipeCoreCheck BE.fragment C.Recon SinkDiscard [ PipeCoreSimplify BE.fragment (0 :: Int) C.lambdas [ PipeCoreOutput pprDefaultMode- (dump config source "dump.tetra-lambdas.dct")+ (dump config source "dump.1-tetra-02-lambdas.dct") , pipe_curry]] pipe_curry = PipeCoreCheck BE.fragment C.Recon SinkDiscard [ PipeCoreAsTetra- [ PipeTetraCurry+ [ PipeTetraCurry (dump config source "dump.1-tetra-03-unshare.dct") [ PipeCoreOutput pprDefaultMode- (dump config source "dump.tetra-curry.dct")+ (dump config source "dump.1-tetra-04-curry.dct") , pipe_prep ]]] pipe_prep@@ -101,10 +107,10 @@ = PipeCoreAsTetra [ PipeTetraBoxing [ PipeCoreOutput pprDefaultMode- (dump config source "dump.tetra-boxing-raw.dct")+ (dump config source "dump.1-tetra-05-boxing-raw.dct") , PipeCoreSimplify BE.fragment 0 (normalize `mappend` C.flatten) [ PipeCoreOutput pprDefaultMode- (dump config source "dump.tetra-boxing-simp.dct")+ (dump config source "dump.1-tetra-06-boxing-simp.dct") , pipe_toSalt]]] @@ -114,6 +120,6 @@ [ PipeTetraToSalt (B.buildSpec $ configBuilder config) (configRuntime config) ( PipeCoreOutput pprDefaultMode- (dump config source "dump.salt.dcs")+ (dump config source "dump.2-salt-00-convert.dcs") : pipesSalt)]]
LICENSE view
@@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- The Disciplined Disciple Compiler License (MIT style) -Copyrite (K) 2007-2014 The Disciplined Disciple Compiler Strike Force+Copyrite (K) 2007-2016 The Disciplined Disciple Compiler Strike Force All rights reversed. Permission is hereby granted, free of charge, to any person obtaining a copy
ddc-driver.cabal view
@@ -1,5 +1,5 @@ Name: ddc-driver-Version: 0.4.2.2+Version: 0.4.3.1 License: MIT License-file: LICENSE Author: The Disciplined Disciple Compiler Strike Force@@ -17,31 +17,27 @@ Library Build-depends:- base >= 4.6 && < 4.9,- process >= 1.1 && < 1.3,+ base >= 4.6 && < 4.10,+ process >= 1.4 && < 1.5, deepseq >= 1.3 && < 1.5,- containers == 0.5.*,+ time >= 1.6 && < 1.7, filepath >= 1.3 && < 1.5,+ containers == 0.5.*, mtl == 2.2.1.*, directory == 1.2.*,- transformers == 0.4.*,- 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.2 && < 0.4.3,- ddc-core-flow == 0.4.2.*,- ddc-core-tetra == 0.4.2.*,- ddc-source-tetra == 0.4.2.*,- ddc-build >= 0.4.2.2 && < 0.4.3+ transformers == 0.5.*,+ ddc-core == 0.4.3.*,+ ddc-core-simpl == 0.4.3.*,+ ddc-core-salt == 0.4.3.*,+ ddc-core-llvm == 0.4.3.*,+ ddc-core-flow == 0.4.3.*,+ ddc-core-tetra == 0.4.3.*,+ ddc-source-tetra == 0.4.3.*,+ ddc-build == 0.4.3.* 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@@ -63,12 +59,16 @@ DDC.Driver.Command.Parse DDC.Driver.Command.Read DDC.Driver.Command.RewriteRules+ DDC.Driver.Command.Scan DDC.Driver.Command.ToC DDC.Driver.Command.ToLlvm DDC.Driver.Command.ToPHP DDC.Driver.Command.ToSalt DDC.Driver.Command.Trans + DDC.Driver.Interface.Input+ DDC.Driver.Interface.Source+ DDC.Driver.Stage.Flow DDC.Driver.Stage.Salt DDC.Driver.Stage.Tetra@@ -80,6 +80,7 @@ Extensions: ExistentialQuantification+ ScopedTypeVariables RankNTypes PatternGuards