module DDC.Driver.Command.Load
( cmdLoadFromFile
, cmdLoadSourceTetraFromFile
, cmdLoadSourceTetraFromString
, cmdLoadCoreFromFile
, cmdLoadCoreFromString
, cmdLoadSimplifier
, cmdLoadSimplifierIntoBundle)
where
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.Core.Exp.Annot.AnTEC
import DDC.Core.Pretty
import DDC.Data.SourcePos
import Control.Monad
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
cmdLoadFromFile
:: Config
-> Store
-> Maybe String
-> [FilePath]
-> FilePath
-> ExceptT String IO ()
cmdLoadFromFile config store mStrSimpl fsTemplates filePath
| ".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
| ".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
| ".ds" <- takeExtension filePath
= case mStrSimpl of
Nothing
-> do cmdLoadSourceTetraFromFile config store Tetra.bundle filePath
Just strSimpl
-> do
bundle' <- cmdLoadSimplifierIntoBundle config
Tetra.bundle strSimpl fsTemplates
cmdLoadSourceTetraFromFile config store bundle' filePath
| Just language <- languageOfExtension (takeExtension filePath)
= case mStrSimpl of
Nothing
-> cmdLoadCoreFromFile config language filePath
Just strSimpl
-> do language' <- cmdLoadSimplifier config language strSimpl fsTemplates
cmdLoadCoreFromFile config language' filePath
| otherwise
= let ext = takeExtension filePath
in throwE $ "Cannot load '" ++ ext ++ "' files."
cmdLoadSourceTetraFromFile
:: Config
-> Store
-> Bundle Int Tetra.Name Tetra.Error
-> FilePath
-> ExceptT String IO ()
cmdLoadSourceTetraFromFile config store bundle filePath
= do
exists <- liftIO $ doesFileExist filePath
when (not exists)
$ throwE $ "No such file " ++ show filePath
cmdCompileRecursive config False store filePath
src <- liftIO $ readFile filePath
cmdLoadSourceTetraFromString config store bundle
(SourceFile filePath) src
cmdLoadSourceTetraFromString
:: Config
-> Store
-> Bundle Int Tetra.Name Tetra.Error
-> Source
-> String
-> ExceptT String IO ()
cmdLoadSourceTetraFromString config store bundle source str
= let
pmode = prettyModeOfConfig $ configPretty config
pipeLoad
= pipeText (nameOfSource source) (lineStartOfSource source) str
$ 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 -> throwE $ renderIndent $ vcat $ map ppr es
cmdLoadCoreFromFile
:: Config
-> Language
-> FilePath
-> ExceptT String IO ()
cmdLoadCoreFromFile config language filePath
= do
exists <- liftIO $ doesFileExist filePath
when (not exists)
$ throwE $ "No such file " ++ show filePath
src <- liftIO $ readFile filePath
cmdLoadCoreFromString config language (SourceFile filePath) src
cmdLoadCoreFromString
:: Config
-> Language
-> Source
-> String
-> ExceptT String IO ()
cmdLoadCoreFromString config language source str
| Language bundle <- language
, fragment <- bundleFragment bundle
= let
pmode = prettyModeOfConfig $ configPretty config
pipeLoad
= pipeText (nameOfSource source) (lineStartOfSource source) str
$ PipeTextLoadCore fragment
(if configInferTypes config then C.Synth else C.Recon)
SinkDiscard
[ PipeCoreReannotate (\a -> a { annotTail = () })
[ PipeCoreSimplify fragment (bundleStateInit bundle)
(bundleSimplifier bundle)
[ PipeCoreOutput pmode SinkStdout ]]]
in do
errs <- liftIO pipeLoad
case errs of
[] -> return ()
es -> throwE $ renderIndent $ vcat $ map ppr es
cmdLoadSimplifier
:: Config
-> Language
-> String
-> [FilePath]
-> ExceptT String IO Language
cmdLoadSimplifier config language strSimpl fsTemplates
| Language bundle <- language
= do bundle' <- cmdLoadSimplifierIntoBundle config bundle strSimpl fsTemplates
return $ Language bundle'
cmdLoadSimplifierIntoBundle
:: (Ord n, Show n, NFData n, Pretty n, Pretty (err (AnTEC SourcePos n)))
=> Config
-> Bundle s n err
-> String
-> [FilePath]
-> 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
, fragment <- bundleFragment bundle
, readName <- fragmentReadName fragment
= do
mModules
<- liftM sequence
$ mapM (liftIO . cmdReadModule config fragment)
fsTemplates
modules_annot
<- case mModules of
Nothing -> throwE $ "Cannot load inlined module."
Just ms -> return $ ms
let zapAnnot annot = annot { annotTail = () }
let modules_new = map (reannotate zapAnnot) modules_annot
let modules_all = Map.elems modules_bundle ++ modules_new
let details
= SimplifierDetails mkNamT mkNamX
[(n, reannotate zapAnnot rule) | (n, rule) <- Map.assocs rules]
modules_all
case parseSimplifier readName details strSimpl of
Left err -> throwE $ renderIndent $ ppr err
Right simpl -> return $ bundle { bundleSimplifier = simpl }