diff options
Diffstat (limited to 'Main.hs')
| -rw-r--r-- | Main.hs | 95 |
1 files changed, 74 insertions, 21 deletions
@@ -1,5 +1,7 @@ module Main where +import Data.List (isPrefixOf) +import Control.Category ((>>>)) import Control.Monad (forM_, when) import Control.Monad.Identity (Identity) import Data.Aeson (ToJSON (..), Value (..), encode) @@ -9,6 +11,8 @@ import Data.Typeable import GHC.IO.Exception (ExitCode (ExitFailure, ExitSuccess)) import Language.Fiddle.Ast import Language.Fiddle.Compiler +import Language.Fiddle.Compiler.Backend +import Language.Fiddle.Compiler.Backend.C import Language.Fiddle.Compiler.ConsistencyCheck import Language.Fiddle.Compiler.Expansion import Language.Fiddle.Compiler.ImportResolution @@ -17,10 +21,10 @@ import Language.Fiddle.Compiler.Stage0 import Language.Fiddle.GenericTree import Language.Fiddle.Types (Commented (unCommented), SourceSpan) import Options.Applicative +import Options.Applicative.Types (ParserHelp (..)) import qualified System.Environment as System import System.Exit (exitWith) -import System.IO (stderr, hPutStrLn) -import Control.Category ((>>>)) +import System.IO (hPutStrLn, stderr) newtype IntermediateAst = IntermediateAst (GenericSyntaxTree Identity (Maybe Value)) deriving (Typeable) @@ -85,7 +89,8 @@ dumpPhase stageName = -- | Global flags for the compiler. data GlobalFlags = GlobalFlags { flagsInputFile :: String, - flagsDiagnosticFormat :: DiagnosticFormat + flagsDiagnosticFormat :: DiagnosticFormat, + flagsBackend :: String } -- | Parse global flags from command line arguments. @@ -93,10 +98,18 @@ parseGlobalFlags :: Parser GlobalFlags parseGlobalFlags = GlobalFlags <$> argument str (metavar "INPUT" <> help "Input file") - <*> ((\b -> if b then jsonDiagnosticFormat else coloredFormat) <$> switch - ( long "diagnostics-as-json" - <> help "Dump diagnostics in JSON format." - )) + <*> ( (\b -> if b then jsonDiagnosticFormat else coloredFormat) + <$> switch + ( long "diagnostics-as-json" + <> help "Dump diagnostics in JSON format." + ) + ) + <*> strOption + ( long "language" + <> short 'L' + <> help "The output language" + <> metavar "LANGUAGE" + ) -- | Parse the input file into the initial AST stages. doParse :: String -> IO ([Diagnostic], [Artifact], Maybe (TreeType FiddleUnit Parsed)) @@ -111,7 +124,7 @@ runCompilationPipeline :: IO ([Diagnostic], [Artifact], Maybe (TreeType FiddleUnit Checked)) runCompilationPipeline argv tree = case fromArgs argv of - Success (_, pipelineAction) -> pipelineAction tree + Success (_, pipelineAction, _) -> pipelineAction tree _ -> return ( [Diagnostic Error "Internal parsing failure (this is a bug)." (unCommented $ annot tree)], @@ -125,36 +138,71 @@ fromArgs :: ParserResult ( GlobalFlags, TreeType FiddleUnit Parsed -> - IO ([Diagnostic], [Artifact], Maybe (TreeType FiddleUnit Checked)) + IO ([Diagnostic], [Artifact], Maybe (TreeType FiddleUnit Checked)), + FiddleUnit Checked Identity (Commented SourceSpan) -> IO TranspileResult ) fromArgs argv = - execParserPure - defaultPrefs - ( info - ( (,) + case selectBackend argv of + Just backend -> do + execParserPure + defaultPrefs + (parserInfo backend) + argv + Nothing -> + Failure $ + parserFailure + defaultPrefs + (parserInfo nullBackend) + (ErrorMsg "Unknown backend") + mempty + where + selectBackend :: [String] -> Maybe Backend + selectBackend argv = selectBackendEq argv <|> selectBackendSpace argv + + selectBackendEq argv = + case filter ("--language="`isPrefixOf`) argv of + [backend] -> case break (=='=') backend of + (_, '=' : s) -> selectBackendFromString s + _ -> Nothing + _ -> Nothing + + selectBackendSpace argv = + case break (\s -> s == "--language" || "-L" `isPrefixOf` s) argv of + (_, "--language" : s : _) -> selectBackendFromString s + (_, "-L" : s : _) -> selectBackendFromString s + (_, ('-' : 'L' : s) : _) -> selectBackendFromString s + _ -> Nothing + + selectBackendFromString "c" = Just cBackend + selectBackendFromString "null" = Just nullBackend + selectBackendFromString _ = Nothing + + + parserInfo backend = + info + ( (,,) <$> parseGlobalFlags <*> execCompilationPipelineWithCmdline (compilationPipeline doParse (runCompilationPipeline argv)) + <*> backendToParserFunction backend <**> helper ) ( fullDesc <> progDesc "Compile Fiddle Files" <> header "fiddlec - A compiler for Fiddle files" ) - ) - argv main :: IO () main = do argv <- System.getArgs - (globalFlags, compilationAction) <- parseCommandLineArgs argv + (globalFlags, compilationAction, backendAction) <- parseCommandLineArgs argv let filePath = flagsInputFile globalFlags maybeParsedAst <- parseInputFile filePath case maybeParsedAst of (priorDiags, _, Just ast) -> do ((priorDiags ++) -> diags, artifacts, ma) <- compilationAction ast - exitCode <- processCompilationResult artifacts ma + exitCode <- processCompilationResult artifacts ma backendAction printDiagnostics (flagsDiagnosticFormat globalFlags) diags exitWith exitCode (diags, _, _) -> @@ -166,7 +214,8 @@ parseCommandLineArgs :: IO ( GlobalFlags, TreeType FiddleUnit Parsed -> - IO ([Diagnostic], [Artifact], Maybe (TreeType FiddleUnit Checked)) + IO ([Diagnostic], [Artifact], Maybe (TreeType FiddleUnit Checked)), + FiddleUnit Checked Identity (Commented SourceSpan) -> IO TranspileResult ) parseCommandLineArgs argv = handleParseResult (fromArgs argv) @@ -177,8 +226,11 @@ parseInputFile filePath = do return $ compile_ $ toStage0 filePath text >>= toStage1 -- | Process the compilation result, printing the output and returning the exit code. -processCompilationResult :: [Artifact] -> Maybe (TreeType FiddleUnit Checked) -> IO ExitCode -processCompilationResult artifacts ma = do +processCompilationResult :: + [Artifact] -> Maybe (TreeType FiddleUnit Checked) -> + (TreeType FiddleUnit Checked -> IO TranspileResult) + -> IO ExitCode +processCompilationResult artifacts ma backendFunction = do forM_ artifacts $ \case Artifact (cast -> (Just (IntermediateAst ast))) -> putStrLn $ @@ -188,7 +240,8 @@ processCompilationResult artifacts ma = do Artifact _ -> return () case ma of - Just _ -> do + Just ast -> do + processTranspileResult =<< backendFunction ast return ExitSuccess Nothing -> do return (ExitFailure 1) |