Add backend support and start implementing a C backend.o

1 files changed, 74 insertions, 21 deletions

diff --git a/Main.hs b/Main.hs
index 97be0a3..0cdba7a 100644
--- a/Main.hs
+++ b/Main.hs
@@ -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)