diff options
Diffstat (limited to 'Main.hs')
| -rw-r--r-- | Main.hs | 207 |
1 files changed, 207 insertions, 0 deletions
@@ -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 |