Another monolithic change. Not good git ettiquite.

Import statements are fully implemented including compiling to an
interface file for faster compilations.

1 files changed, 112 insertions, 53 deletions

diff --git a/src/Main.hs b/src/Main.hs
index 352a8cc..393fb69 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -2,12 +2,10 @@ module Main where
 
 import Control.Monad (forM_)
 import Control.Monad.Identity (Identity)
-import Control.Monad.Writer
-import Data.Aeson (Value (Null), encode)
+import Data.Aeson (Value (Null, String), encode)
 import qualified Data.ByteString.Lazy.Char8 as BL
-import Data.Data (cast)
 import qualified Data.Text as Text
-import qualified Data.Text.IO
+import qualified Data.Text.IO as TextIO
 import Data.Typeable
 import GHC.IO.Exception (ExitCode (ExitFailure, ExitSuccess))
 import Language.Fiddle.Ast
@@ -16,80 +14,141 @@ import Language.Fiddle.Compiler.ConsistencyCheck
 import Language.Fiddle.Compiler.Expansion
 import Language.Fiddle.Compiler.ImportResolution
 import Language.Fiddle.Compiler.Stage0
-import Language.Fiddle.GenericTree (GenericSyntaxTree (..), ToGenericSyntaxTree (toGenericSyntaxTree), alterGenericSyntaxTree)
+import Language.Fiddle.GenericTree
+  ( GenericSyntaxTree (..),
+    ToGenericSyntaxTree (toGenericSyntaxTree),
+    alterGenericSyntaxTree,
+  )
 import qualified Language.Fiddle.Parser
 import qualified Language.Fiddle.Tokenizer
+import Language.Fiddle.Types (Commented (unCommented))
 import Options.Applicative
 import qualified System.Environment as System
 import System.Exit (exitWith)
+import System.IO
 
-compilationPipeline =
-  importResolutionPhase >>> expansionPhase >>> consistencyCheckPhase
+-- compilationPipeline :: _ -> _ -> CompilationPhase Parsed Checked
+compilationPipeline parse compile =
+  importResolutionPhase parse compile >>> expansionPhase >>> consistencyCheckPhase
 
-newtype GlobalFlags
-  = GlobalFlags
-  { flagsInputFile :: String
-  }
+-- | 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")
+parseGlobalFlags = GlobalFlags <$> argument str (metavar "INPUT" <> help "Input file")
 
-main :: IO ()
-main = do
-  (globalFlags, compilationPipelineAction) <-
-    execParser $
-      info
-        ( ( (,)
-              <$> parseGlobalFlags
-              <*> execCompilationPipelineWithCmdline compilationPipeline
-          )
-            <**> helper
+-- | 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
+    Failure failure ->
+      return
+        ( [Diagnostic Error "Internal parsing failure (this is a bug)." (unCommented $ annot tree)],
+          Nothing
+        )
+    Success (_, pipelineAction) -> pipelineAction tree
+
+-- | 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"
+            <> header "fiddlec - A compiler for Fiddle files"
         )
+    )
+    argv
 
+main :: IO ()
+main = do
+  argv <- System.getArgs
+  (globalFlags, compilationAction) <- parseCommandLineArgs argv
   let filePath = flagsInputFile globalFlags
-  text <- Data.Text.IO.readFile filePath
 
-  let maybeParsedAst = compile_ $ toStage0 filePath text >>= toStage1
+  maybeParsedAst <- parseInputFile filePath
   case maybeParsedAst of
     (priorDiags, Just ast) -> do
-      ((priorDiags ++) -> diags, ma) <- compilationPipelineAction ast
-      ec <-
-        case ma of
-          Just ast -> do
-            putStrLn $
-              BL.unpack $
-                encode $
-                  alterGenericSyntaxTree cleanupIdentifiers $
-                    toGenericSyntaxTree $
-                      fmap
-                        (const (Nothing :: Maybe Value))
-                        ast
-            return ExitSuccess
-          Nothing -> do
-            putStrLn "\x1b[1;31mCompilation Failed\x1b[0m"
-            return (ExitFailure 1)
-
-      forM_ diags printDiagnostic
-      exitWith ec
-    (diags, _) -> do
-      putStrLn "\x1b[1;31mParsing Failed\x1b[0m"
+      ((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 =
+  case fromArgs argv of
+    Failure failure -> do
+      hPutStrLn stderr (fst $ renderFailure failure "")
       exitWith (ExitFailure 1)
+    Success v -> return v
+
+-- | 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 . String . Text.pack . show) 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 (Identifier n _) <- castT tr =
       Just $ SyntaxTreeValue (Text.unpack n)
   where
-    castT ::
-      (Typeable t, Typeable f, Typeable a, Typeable t') =>
-      t f a ->
-      Maybe (t' f a)
+    castT :: (Typeable t, Typeable f, Typeable a, Typeable t') => t f a -> Maybe (t' f a)
     castT = cast
 cleanupIdentifiers _ = Nothing