module DDC.Driver.Command.Load
( cmdReadModule
, cmdReadModule'
, cmdLoadFromFile
, cmdLoadFromString)
where
import DDC.Driver.Source
import DDC.Build.Pipeline
import DDC.Build.Language
import DDC.Core.Simplifier.Parser
import DDC.Core.Module
import DDC.Core.Load
import DDC.Core.Pretty
import DDC.Data.Canned
import Control.DeepSeq
import Control.Monad
import Control.Monad.Trans.Error
import Control.Monad.IO.Class
import Data.IORef
import System.Directory
import System.FilePath
import System.IO
import qualified Data.Map as Map
cmdReadModule
:: (Ord n, Show n, Pretty n, NFData n)
=> Fragment n err
-> FilePath
-> IO (Maybe (Module (AnTEC () n) n))
cmdReadModule = cmdReadModule' True
cmdReadModule'
:: (Ord n, Show n, Pretty n, NFData n)
=> Bool
-> Fragment n err
-> FilePath
-> IO (Maybe (Module (AnTEC () n) n))
cmdReadModule' printErrors frag filePath
= do
exists <- doesFileExist filePath
when (not exists)
$ error $ "No such file " ++ show filePath
src <- readFile filePath
let source = SourceFile filePath
cmdReadModule_parse printErrors filePath frag source src
cmdReadModule_parse printErrors filePath frag source src
= do ref <- newIORef Nothing
errs <- pipeText (nameOfSource source) (lineStartOfSource source) src
$ PipeTextLoadCore frag
[ PipeCoreHacks (Canned (\m -> writeIORef ref (Just m) >> return m))
[PipeCoreOutput SinkDiscard] ]
case errs of
[] -> do
readIORef ref
_ -> do
when printErrors
$ do putStrLn $ "When reading " ++ filePath
mapM_ (hPutStrLn stderr . renderIndent . ppr) errs
return Nothing
cmdLoadFromFile
:: Maybe String
-> [FilePath]
-> FilePath
-> ErrorT String IO ()
cmdLoadFromFile strSimpl fsTemplates filePath
= case languageOfExtension (takeExtension filePath) of
Nothing -> throwError $ "Unknown file extension."
Just language -> cmdLoad_language strSimpl fsTemplates filePath language
cmdLoad_language Nothing _ filePath language
= configLoad_simpl language filePath
cmdLoad_language (Just strSimpl) fsTemplates filePath language
| Language bundle <- language
, modules <- bundleModules bundle
, rules <- bundleRewriteRules bundle
, mkNamT <- bundleMakeNamifierT bundle
, mkNamX <- bundleMakeNamifierX bundle
, fragment <- bundleFragment bundle
, readName <- fragmentReadName fragment
= do
let rules' = Map.assocs rules
mMoreModules
<- liftM sequence
$ mapM (liftIO . cmdReadModule fragment)
fsTemplates
moreModules
<- case mMoreModules of
Nothing -> throwError $ "Imported modules do not parse."
Just ms -> return ms
let templateModules
= moreModules ++ (Map.elems modules)
let details
= SimplifierDetails mkNamT mkNamX rules'
templateModules
case parseSimplifier readName details strSimpl of
Left err
-> throwError $ renderIndent $ ppr err
Right simpl
-> let bundle' = bundle { bundleSimplifier = simpl }
in configLoad_simpl (Language bundle') filePath
configLoad_simpl language filePath
= do
exists <- liftIO $ doesFileExist filePath
when (not exists)
$ throwError $ "No such file " ++ show filePath
src <- liftIO $ readFile filePath
cmdLoadFromString language (SourceFile filePath) src
cmdLoadFromString
:: Language
-> Source
-> String
-> ErrorT String IO ()
cmdLoadFromString language source str
| Language bundle <- language
, fragment <- bundleFragment bundle
, simpl <- bundleSimplifier bundle
, zero <- bundleStateInit bundle
= do errs <- liftIO
$ pipeText (nameOfSource source) (lineStartOfSource source) str
$ PipeTextLoadCore fragment
[ PipeCoreSimplify fragment zero simpl
[ PipeCoreCheck fragment
[ PipeCoreOutput SinkStdout ]]]
case errs of
[] -> return ()
es -> throwError $ renderIndent $ vcat $ map ppr es