diff options
Diffstat (limited to 'src/Main.hs')
| -rw-r--r-- | src/Main.hs | 162 |
1 files changed, 0 insertions, 162 deletions
diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 index 2e4ee7a..0000000 --- a/src/Main.hs +++ /dev/null @@ -1,162 +0,0 @@ -module Main where - -import Control.Monad (forM_) -import Control.Monad.Identity (Identity) -import Data.Aeson (ToJSON (..), Value (..), encode) -import qualified Data.ByteString.Lazy.Char8 as BL -import qualified Data.Text as Text -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) - -compilationPipeline :: - ( FilePath -> - IO - ( [Diagnostic], - Maybe - ( FiddleUnit Parsed Identity (Commented SourceSpan) - ) - ) - ) -> - ( FiddleUnit Parsed Identity (Commented SourceSpan) -> - IO - ( [Diagnostic], - Maybe - (FiddleUnit Checked Identity (Commented SourceSpan)) - ) - ) -> - CompilationPhase Parsed Checked -compilationPipeline parse compile = - importResolutionPhase parse compile - >>> expansionPhase - >>> qualificationPhase - >>> consistencyCheckPhase - --- | Global flags for the compiler. -newtype GlobalFlags = GlobalFlags - {flagsInputFile :: String} - --- | Parse global flags from command line arguments. -parseGlobalFlags :: Parser GlobalFlags -parseGlobalFlags = GlobalFlags <$> argument str (metavar "INPUT" <> help "Input file") - --- | Parse the input file into the initial AST stages. -doParse :: String -> IO ([Diagnostic], 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], 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], 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, ma) <- compilationAction ast - exitCode <- processCompilationResult ma - forM_ diags printDiagnostic - exitWith exitCode - (diags, _) -> handleParsingFailure diags - --- | Parse command-line arguments, exiting on failure. -parseCommandLineArgs :: - [String] -> - IO - ( GlobalFlags, - TreeType FiddleUnit Parsed -> - IO ([Diagnostic], Maybe (TreeType FiddleUnit Checked)) - ) -parseCommandLineArgs argv = handleParseResult (fromArgs argv) - --- | Parse the input file into the initial AST. -parseInputFile :: String -> IO ([Diagnostic], 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 :: Maybe (TreeType FiddleUnit Checked) -> IO ExitCode -processCompilationResult ma = - case ma of - Just ast -> do - putStrLn $ - BL.unpack $ - encode $ - alterGenericSyntaxTree cleanupIdentifiers $ - toGenericSyntaxTree $ - fmap (Just . toJSON) ast - return ExitSuccess - Nothing -> do - putStrLn "\x1b[1;31mCompilation Failed\x1b[0m" - return (ExitFailure 1) - --- | Handle parsing failures by printing diagnostics and exiting with an error code. -handleParsingFailure :: [Diagnostic] -> IO () -handleParsingFailure diags = do - putStrLn "\x1b[1;31mParsing Failed\x1b[0m" - forM_ diags printDiagnostic - 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 |