module DDC.Driver.Command.Compile
( cmdCompileRecursive
, cmdCompileRecursiveDS
, cmdLoadOrCompile
, cmdCompile
, getModificationTimeIfExists)
where
import DDC.Driver.Stage
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.Except
import Control.Monad.IO.Class
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
import DDC.Build.Interface.Store (Store)
import qualified DDC.Build.Interface.Store as Store
cmdCompileRecursive
:: Config
-> Bool
-> Store
-> FilePath
-> ExceptT String IO ()
cmdCompileRecursive config bBuildExe store filePath
| takeExtension filePath == ".ds"
= do cmdCompileRecursiveDS config bBuildExe store [filePath] []
| otherwise
= do cmdCompile config bBuildExe store filePath
cmdCompileRecursiveDS
:: Config
-> Bool
-> Store
-> [FilePath]
-> [FilePath]
-> ExceptT String IO ()
cmdCompileRecursiveDS _config _bBuildExe _store [] _fsBlocked
= return ()
cmdCompileRecursiveDS config bBuildExe store (filePath:fs) fsBlocked
= do
exists <- liftIO $ doesFileExist filePath
when (not exists)
$ throwE $ "No such file " ++ show filePath
src <- liftIO $ readFile filePath
modNamesNeeded <- tasteNeeded filePath src
modsNamesHave <- liftIO $ Store.getModuleNames store
let missing = filter (\m -> not $ elem m modsNamesHave)
$ modNamesNeeded
case missing of
[] -> do
cmdLoadOrCompile config bBuildExe store filePath
cmdCompileRecursiveDS config bBuildExe store fs []
ms -> do
fsMore <- mapM (locateModuleFromConfig config) ms
let fsRec = List.intersect fsMore fsBlocked
when (not $ null fsRec)
$ throwE $ unlines
$ [ "Cannot build recursive module" ]
++ [ " " ++ show fsRec ]
cmdCompileRecursiveDS config bBuildExe store
(List.nub $ fsMore ++ fs ++ [filePath])
(filePath : fsBlocked)
cmdLoadOrCompile
:: Config
-> Bool
-> Store
-> FilePath
-> ExceptT String IO ()
cmdLoadOrCompile config buildExe store filePath
= do
exists <- liftIO $ doesFileExist filePath
when (not exists)
$ throwE $ "No such file " ++ show filePath
src <- liftIO $ readFile filePath
Just timeDS <- liftIO $ getModificationTimeIfExists filePath
modNamesNeeded <- tasteNeeded filePath src
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
| Just timeO <- mTimeO, timeDS < timeO
, Just timeDI <- mTimeDI, timeDS < timeDI
, and [ Store.metaTimeStamp m <= timeDI
| m <- meta'
, elem (Store.metaModuleName m) modNamesNeeded ]
, 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
cmdCompile
:: Config
-> Bool
-> Store
-> FilePath
-> 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
exists <- liftIO $ doesFileExist filePath
when (not exists)
$ throwE $ "No such file " ++ show filePath
src <- liftIO $ readFile filePath
metas <- liftIO $ Store.getMeta store
let pathsDI = map Store.metaFilePath metas
let otherObjs
| buildExe = Just $ map (\path -> replaceExtension path "o") pathsDI
| otherwise = Nothing
refTetra <- liftIO $ newIORef Nothing
refSalt <- liftIO $ newIORef Nothing
let make
| ext == ".ds"
= liftIO
$ pipeText (nameOfSource source) (lineStartOfSource source) src
$ stageSourceTetraLoad config source store
[ PipeCoreHacks (Canned $ \m -> writeIORef refTetra (Just m) >> return m)
[ PipeCoreReannotate (const ())
[ stageTetraToSalt config source pipesSalt ]]]
| ext == ".dct"
= liftIO
$ pipeText (nameOfSource source) (lineStartOfSource source) src
$ stageTetraLoad config source
[ stageTetraToSalt config source pipesSalt ]
| ext == ".dcs"
= liftIO
$ pipeText (nameOfSource source) (lineStartOfSource source) src
$ stageSaltLoad config source pipesSalt
| ext == ".dcf"
= liftIO
$ pipeText (nameOfSource source) (lineStartOfSource source) src
$ pipelineFlowToTetra config Flow.defaultConfigScalar source pipesSalt
| otherwise
= throwE $ "Cannot compile '" ++ ext ++ "' files."
pipesSalt
= case configViaBackend config of
ViaLLVM
-> [ PipeCoreReannotate (const ())
[ 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 ]]]
errs <- make
modTetra <- liftIO $ readIORef refTetra
modSalt <- liftIO $ readIORef refSalt
case errs of
es@(_:_)
-> throwE $ P.renderIndent $ P.vcat $ map P.ppr es
[]
| Just (mn : _)
<- sequence
[ liftM C.moduleName modTetra
, liftM C.moduleName modSalt ]
-> do
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
liftIO $ Store.wrap store int
return ()
| otherwise
-> return ()
tasteNeeded
:: FilePath
-> String
-> ExceptT String IO [C.ModuleName]
tasteNeeded filePath src
| takeExtension filePath == ".ds"
= do
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 []
locateModuleFromConfig
:: Config
-> C.ModuleName
-> ExceptT String IO FilePath
locateModuleFromConfig config mname
= do
let baseDirs
= configModuleBaseDirectories config
++ [Builder.buildBaseSrcDir (configBuilder config)
</> "tetra" </> "base"]
Locate.locateModuleFromPaths baseDirs mname ".ds"
getModificationTimeIfExists :: FilePath -> IO (Maybe UTCTime)
getModificationTimeIfExists path
= do exists <- doesFileExist path
if exists
then do
timeStamp <- getModificationTime path
return $ Just timeStamp
else return Nothing
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