module DDC.Driver.Command.Parse
( cmdParseFromFile
, cmdParseSourceTetraFromFile
, cmdParseCoreFromFile)
where
import DDC.Driver.Stage
import DDC.Build.Language
import DDC.Source.Tetra.Pretty
import DDC.Source.Tetra.Lexer as ST
import DDC.Source.Tetra.Parser as ST
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 Control.Monad.Trans.Error
import Control.Monad.IO.Class
import System.FilePath
import System.Directory
import Control.Monad
cmdParseFromFile
:: Config
-> FilePath
-> ErrorT String IO ()
cmdParseFromFile config filePath
| ".dst" <- takeExtension filePath
= cmdParseSourceTetraFromFile config filePath
| Just language <- languageOfExtension (takeExtension filePath)
= cmdParseCoreFromFile config language filePath
| otherwise
= let ext = takeExtension filePath
in throwError $ "Cannot parse '" ++ ext ++ "' files."
cmdParseSourceTetraFromFile
:: Config
-> FilePath
-> ErrorT String IO ()
cmdParseSourceTetraFromFile config filePath
= do
exists <- liftIO $ doesFileExist filePath
when (not exists)
$ throwError $ "No such file " ++ show filePath
src <- liftIO $ readFile filePath
let toks = ST.lexModuleString filePath 1 src
when (configDump config)
$ liftIO $ writeFile "dump.tetra-parse.tokens-sp"
$ unlines $ map show toks
when (configDump config)
$ liftIO $ writeFile "dump.tetra-parse.tokens"
$ unlines $ map show $ map Token.tokenTok toks
let context = ST.Context
{ ST.contextTrackedEffects = True
, ST.contextTrackedClosures = True
, ST.contextFunctionalEffects = False
, ST.contextFunctionalClosures = False }
case BP.runTokenParser
C.describeTok filePath
(ST.pModule context) toks of
Left err
-> throwError (renderIndent $ ppr err)
Right mm
-> liftIO $ putStrLn (renderIndent $ ppr mm)
cmdParseCoreFromFile
:: Config
-> Language
-> FilePath
-> ErrorT String IO ()
cmdParseCoreFromFile _config language filePath
| Language bundle <- language
, fragment <- bundleFragment bundle
, profile <- fragmentProfile fragment
= do
exists <- liftIO $ doesFileExist filePath
when (not exists)
$ throwError $ "No such file " ++ show filePath
src <- liftIO $ readFile filePath
let toks = (C.fragmentLexModule fragment) filePath 1 src
case BP.runTokenParser
C.describeTok filePath
(C.pModule (C.contextOfProfile profile)) toks of
Left err
-> throwError (renderIndent $ ppr err)
Right mm
-> liftIO $ putStrLn (renderIndent $ ppr mm)