Prepare code to make testing much easier.

This is primarily done by making more things json and by instrumenting
which stage in compilation to dump and others. This means I can make
bash scripts for end to end testing.

1 files changed, 207 insertions, 0 deletions

diff --git a/Main.hs b/Main.hs
new file mode 100644
index 0000000..34ef997
--- /dev/null
+++ b/Main.hs
@@ -0,0 +1,207 @@
+module Main where
+
+import Control.Monad (forM_, when)
+import Control.Monad.Identity (Identity)
+import Data.Aeson (ToJSON (..), Value (..), encode)
+import qualified Data.ByteString.Lazy.Char8 as BL
+import qualified Data.Text.IO as TextIO
+import Data.Typeable
+import GHC.IO.Exception (ExitCode (ExitFailure, ExitSuccess))
+import Language.Fiddle.Ast
+import Language.Fiddle.Compiler
+import Language.Fiddle.Compiler.ConsistencyCheck
+import Language.Fiddle.Compiler.Expansion
+import Language.Fiddle.Compiler.ImportResolution
+import Language.Fiddle.Compiler.Qualification
+import Language.Fiddle.Compiler.Stage0
+import Language.Fiddle.GenericTree
+import Language.Fiddle.Types (Commented (unCommented), SourceSpan)
+import Options.Applicative
+import qualified System.Environment as System
+import System.Exit (exitWith)
+import System.IO (stderr, hPutStrLn)
+
+newtype IntermediateAst = IntermediateAst (GenericSyntaxTree Identity (Maybe Value))
+  deriving (Typeable)
+
+compilationPipeline ::
+  ( FilePath ->
+    IO
+      ( [Diagnostic],
+        [Artifact],
+        Maybe
+          ( FiddleUnit Parsed Identity (Commented SourceSpan)
+          )
+      )
+  ) ->
+  ( FiddleUnit Parsed Identity (Commented SourceSpan) ->
+    IO
+      ( [Diagnostic],
+        [Artifact],
+        Maybe
+          (FiddleUnit Checked Identity (Commented SourceSpan))
+      )
+  ) ->
+  CompilationPhase Parsed Checked
+compilationPipeline parse compile =
+  (dumpPhase "parsed" >>> importResolutionPhase parse compile)
+    >>> (dumpPhase "imports-resolved" >>> expansionPhase)
+    >>> (dumpPhase "expanded" >>> qualificationPhase)
+    >>> (dumpPhase "qualified" >>> consistencyCheckPhase)
+    >>> dumpPhase "checked"
+
+dumpPhase ::
+  forall stage.
+  ( Typeable stage,
+    Typeable (StageAnnotation stage),
+    ToGenericSyntaxTree (FiddleUnit stage),
+    StageAnnotation stage ~ Commented SourceSpan
+  ) =>
+  String ->
+  CompilationPhase stage stage
+dumpPhase stageName =
+  CompilationPhase
+    ( switch
+        ( long ("dump-" ++ stageName)
+            <> help
+              ( "Dump the "
+                  ++ stageName
+                  ++ " intermediate ast as parseable JSON."
+              )
+        )
+    )
+    (\_ _ -> return ([], Just ()))
+    ( \enable () ast -> do
+        when enable $
+          emitArtifact $
+            Artifact $
+              IntermediateAst (toGenericSyntaxTree (fmap (Just . toJSON) ast))
+        return ast
+    )
+
+-- | Global flags for the compiler.
+data GlobalFlags = GlobalFlags
+  { flagsInputFile :: String,
+    flagsDiagnosticFormat :: DiagnosticFormat
+  }
+
+-- | Parse global flags from command line arguments.
+parseGlobalFlags :: Parser GlobalFlags
+parseGlobalFlags =
+  GlobalFlags
+    <$> argument str (metavar "INPUT" <> help "Input file")
+    <*> ((\b -> if b then jsonFormat else coloredFormat) <$> switch
+      ( long "diagnostics-as-json"
+          <> help "Dump diagnostics in JSON format."
+      ))
+
+-- | Parse the input file into the initial AST stages.
+doParse :: String -> IO ([Diagnostic], [Artifact], Maybe (TreeType FiddleUnit Parsed))
+doParse filePath = do
+  text <- TextIO.readFile filePath
+  return $ compile_ $ toStage0 filePath text >>= toStage1
+
+-- | Run the compilation pipeline with the given command-line arguments and AST.
+runCompilationPipeline ::
+  [String] ->
+  TreeType FiddleUnit Parsed ->
+  IO ([Diagnostic], [Artifact], Maybe (TreeType FiddleUnit Checked))
+runCompilationPipeline argv tree =
+  case fromArgs argv of
+    Success (_, pipelineAction) -> pipelineAction tree
+    _ ->
+      return
+        ( [Diagnostic Error "Internal parsing failure (this is a bug)." (unCommented $ annot tree)],
+          [],
+          Nothing
+        )
+
+-- | Parse command-line arguments into global flags and a compilation action.
+fromArgs ::
+  [String] ->
+  ParserResult
+    ( GlobalFlags,
+      TreeType FiddleUnit Parsed ->
+      IO ([Diagnostic], [Artifact], Maybe (TreeType FiddleUnit Checked))
+    )
+fromArgs argv =
+  execParserPure
+    defaultPrefs
+    ( info
+        ( (,)
+            <$> parseGlobalFlags
+            <*> execCompilationPipelineWithCmdline
+              (compilationPipeline doParse (runCompilationPipeline argv))
+              <**> 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
+  let filePath = flagsInputFile globalFlags
+
+  maybeParsedAst <- parseInputFile filePath
+  case maybeParsedAst of
+    (priorDiags, _, Just ast) -> do
+      ((priorDiags ++) -> diags, artifacts, ma) <- compilationAction ast
+      exitCode <- processCompilationResult artifacts ma
+      printDiagnostics (flagsDiagnosticFormat globalFlags) diags
+      exitWith exitCode
+    (diags, _, _) ->
+      handleParsingFailure (flagsDiagnosticFormat globalFlags) diags
+
+-- | Parse command-line arguments, exiting on failure.
+parseCommandLineArgs ::
+  [String] ->
+  IO
+    ( GlobalFlags,
+      TreeType FiddleUnit Parsed ->
+      IO ([Diagnostic], [Artifact], Maybe (TreeType FiddleUnit Checked))
+    )
+parseCommandLineArgs argv = handleParseResult (fromArgs argv)
+
+-- | Parse the input file into the initial AST.
+parseInputFile :: String -> IO ([Diagnostic], [Artifact], Maybe (TreeType FiddleUnit Parsed))
+parseInputFile filePath = do
+  text <- TextIO.readFile filePath
+  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
+  forM_ artifacts $ \case
+    Artifact (cast -> (Just (IntermediateAst ast))) ->
+      putStrLn $
+        BL.unpack $
+          encode $
+            alterGenericSyntaxTree cleanupIdentifiers ast
+    Artifact _ -> return ()
+
+  case ma of
+    Just _ -> do
+      return ExitSuccess
+    Nothing -> do
+      return (ExitFailure 1)
+
+-- | Handle parsing failures by printing diagnostics and exiting with an error code.
+handleParsingFailure :: DiagnosticFormat -> [Diagnostic] -> IO ()
+handleParsingFailure fmt diags = do
+  printDiagnostics fmt diags
+  exitWith (ExitFailure 1)
+
+-- | Clean up identifiers in the generic syntax tree for serialization.
+cleanupIdentifiers :: GenericSyntaxTree Identity a -> Maybe (GenericSyntaxTree Identity a)
+cleanupIdentifiers (SyntaxTreeObject _ _ _ tr)
+  | Just (Identifier n _) <- castT tr =
+      Just $ SyntaxTreeValue (String n)
+  where
+    castT :: (Typeable t, Typeable f, Typeable a, Typeable t') => t f a -> Maybe (t' f a)
+    castT = cast
+cleanupIdentifiers _ = Nothing