module DDC.Driver.Command.Load
( cmdLoadFromFile
, cmdLoadSourceTetraFromFile
, cmdLoadSourceTetraFromString
, cmdLoadCoreFromFile
, cmdLoadCoreFromString
, cmdLoadSimplifier)
where
import DDC.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.Pretty
import Control.Monad
import Control.Monad.Trans.Error
import Control.Monad.IO.Class
import System.FilePath
import System.Directory
import qualified Data.Map as Map
import qualified DDC.Core.Check as C
cmdLoadFromFile
:: Config
-> Maybe String
-> [FilePath]
-> FilePath
-> ErrorT String IO ()
cmdLoadFromFile config mStrSimpl fsTemplates filePath
| ".dst" <- takeExtension filePath
= cmdLoadSourceTetraFromFile config 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 throwError $ "Cannot load '" ++ ext ++ "' files."
cmdLoadSourceTetraFromFile
:: Config
-> FilePath
-> ErrorT String IO ()
cmdLoadSourceTetraFromFile config filePath
= do
exists <- liftIO $ doesFileExist filePath
when (not exists)
$ throwError $ "No such file " ++ show filePath
src <- liftIO $ readFile filePath
cmdLoadSourceTetraFromString config (SourceFile filePath) src
cmdLoadSourceTetraFromString
:: Config
-> Source
-> String
-> ErrorT String IO ()
cmdLoadSourceTetraFromString config source str
= let
pmode = prettyModeOfConfig $ configPretty config
pipeLoad
= pipeText (nameOfSource source) (lineStartOfSource source) str
$ stageSourceTetraLoad config source
[ PipeCoreOutput pmode SinkStdout ]
in do
errs <- liftIO pipeLoad
case errs of
[] -> return ()
es -> throwError $ renderIndent $ vcat $ map ppr es
cmdLoadCoreFromFile
:: Config
-> Language
-> FilePath
-> ErrorT String IO ()
cmdLoadCoreFromFile config language filePath
= do
exists <- liftIO $ doesFileExist filePath
when (not exists)
$ throwError $ "No such file " ++ show filePath
src <- liftIO $ readFile filePath
cmdLoadCoreFromString config language (SourceFile filePath) src
cmdLoadCoreFromString
:: Config
-> Language
-> Source
-> String
-> ErrorT String IO ()
cmdLoadCoreFromString config language source str
| Language bundle <- language
, fragment <- bundleFragment bundle
= let
pmode = prettyModeOfConfig $ configPretty config
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)
SinkDiscard
[ PipeCoreReannotate (\a -> a { annotTail = () })
[ PipeCoreSimplify fragment (bundleStateInit bundle)
(bundleSimplifier bundle)
[ PipeCoreOutput pmode SinkStdout ]]]
in do
errs <- liftIO pipeLoad
case errs of
[] -> return ()
es -> throwError $ renderIndent $ vcat $ map ppr es
cmdLoadSimplifier
:: Config
-> Language
-> String
-> [FilePath]
-> ErrorT String IO Language
cmdLoadSimplifier config language strSimpl fsTemplates
| Language bundle <- language
, 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 -> throwError $ "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
-> throwError $ renderIndent $ ppr err
Right simpl
-> return $ Language $ bundle { bundleSimplifier = simpl }