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.

3 files changed, 82 insertions, 205 deletions

diff --git a/src/Language/Fiddle/Compiler.hs b/src/Language/Fiddle/Compiler.hs
index 049d533..812d4f6 100644
--- a/src/Language/Fiddle/Compiler.hs
+++ b/src/Language/Fiddle/Compiler.hs
@@ -11,16 +11,25 @@ import Control.Monad.RWS
 import Control.Monad.Trans.Maybe
 import Control.Monad.Writer
 import Data.Default
+import Data.Typeable
 import Language.Fiddle.Ast
 import Language.Fiddle.Types
 import Options.Applicative
 import System.IO (hPutStrLn, stderr)
+import qualified Data.ByteString.Lazy.Char8 as BL
 import Text.Parsec (sourceColumn, sourceLine, sourceName)
+import Data.Aeson (FromJSON, ToJSON (toJSON), encode)
+import GHC.Generics (Generic)
 
 data Level = Error | Warning | Info
-  deriving (Eq, Ord, Show, Read, Enum)
+  deriving (Eq, Ord, Show, Read, Enum, ToJSON, FromJSON, Generic)
 
-data Diagnostic = Diagnostic Level String SourceSpan
+data Diagnostic = Diagnostic {
+  diagnosticLevel :: Level,
+  diagnosticMesasge :: String,
+  diagnosticLocation :: SourceSpan
+  }
+  deriving (Generic, ToJSON, FromJSON, Typeable)
 
 emitDiagnosticError :: String -> Commented SourceSpan -> Compile a ()
 emitDiagnosticError str a = tell [Diagnostic Error str (unCommented a)]
@@ -31,16 +40,21 @@ emitDiagnosticWarning str a = tell [Diagnostic Warning str (unCommented a)]
 emitDiagnosticInfo :: String -> Commented SourceSpan -> Compile a ()
 emitDiagnosticInfo str a = tell [Diagnostic Info str (unCommented a)]
 
-newtype Compile s a = Compile (MaybeT (RWS () [Diagnostic] s) a)
+data Artifact where
+  Artifact :: forall t. (Typeable t) => t -> Artifact
+
+newtype Compile s a = Compile (MaybeT (RWS () ([Diagnostic], [Artifact]) s) a)
   deriving newtype (Functor, Applicative, Monad)
 
 compilationFailure :: Compile s a
 compilationFailure = Compile $ MaybeT (return Nothing)
 
 instance MonadWriter [Diagnostic] (Compile s) where
-  tell = Compile . tell
-  listen (Compile fn) = Compile $ listen fn
-  pass (Compile fn) = Compile $ pass fn
+  tell t = Compile $ tell (t, [])
+  listen (Compile fn) = Compile $ do
+    (a, (ds, _)) <- listen fn
+    return (a, ds)
+  pass (Compile mfun) = Compile $ pass (second first <$> mfun)
 
 instance MonadState s (Compile s) where
   get = Compile get
@@ -53,28 +67,34 @@ subCompile s' (Compile mtrws) = Compile $ do
   tell w
   MaybeT $ return $ fmap (s,) a
 
+emitArtifact :: Artifact -> Compile s ()
+emitArtifact art = Compile $ tell ([], [art])
+
 pushState :: Compile s a -> Compile s a
 pushState cp = do
   s <- get
   snd <$> subCompile s cp
 
-compile :: Compile s a -> s -> ([Diagnostic], Maybe a)
+compile :: Compile s a -> s -> ([Diagnostic], [Artifact], Maybe a)
 compile (Compile fn) initState = do
-  let (a, _, w) = runRWS (runMaybeT fn) () initState
-   in if hasError w then (w, Nothing) else (w, a)
+  let (a, _, (w, as)) = runRWS (runMaybeT fn) () initState
+   in if hasError w then (w, as, Nothing) else (w, as, a)
   where
     hasError = any (\(Diagnostic e _ _) -> e == Error)
 
-compile_ :: (Default s) => Compile s a -> ([Diagnostic], Maybe a)
+compile_ :: (Default s) => Compile s a -> ([Diagnostic], [Artifact], Maybe a)
 compile_ c = compile c def
 
 hoistMaybe :: Maybe a -> Compile s a
 hoistMaybe = Compile . MaybeT . return
 
-newtype DiagnosticFormat = DiagnosticFormat (Diagnostic -> String)
+newtype DiagnosticFormat = DiagnosticFormat ([Diagnostic] -> String)
+
+jsonFormat :: DiagnosticFormat
+jsonFormat = DiagnosticFormat $ BL.unpack . encode . toJSON
 
 coloredFormat :: DiagnosticFormat
-coloredFormat = DiagnosticFormat $ \(Diagnostic level message (SourceSpan pos1 pos2)) ->
+coloredFormat = DiagnosticFormat $ \diags -> unlines $ map (\(Diagnostic level message (SourceSpan pos1 pos2)) ->
   execWriter $ do
     case level of
       Error -> tell "\x1b[01;31mError "
@@ -90,18 +110,22 @@ coloredFormat = DiagnosticFormat $ \(Diagnostic level message (SourceSpan pos1 p
       tellPos pos2
     tell "): "
     tell (unwords $ words message)
+  ) diags
   where
     tellPos pos = do
       tell (show $ sourceLine pos)
       tell ":"
       tell (show $ sourceColumn pos)
 
-diagnosticToString :: DiagnosticFormat -> Diagnostic -> String
-diagnosticToString (DiagnosticFormat f) = f
+diagnosticsToString :: DiagnosticFormat -> [Diagnostic] -> String
+diagnosticsToString (DiagnosticFormat f) = f
+
+printDiagnostics :: DiagnosticFormat -> [Diagnostic] -> IO ()
+printDiagnostics fmt d = hPutStrLn stderr (diagnosticsToString fmt d)
 
 printDiagnostic :: Diagnostic -> IO ()
 printDiagnostic d =
-  hPutStrLn stderr (diagnosticToString coloredFormat d)
+  hPutStrLn stderr (diagnosticsToString coloredFormat [d])
 
 fromMayberOrFail :: SourceSpan -> String -> Maybe a -> Compile s a
 fromMayberOrFail sourceSpan err Nothing = do
@@ -127,6 +151,9 @@ pureCompilationPhase ::
 pureCompilationPhase fn =
   CompilationPhase (pure ()) (\_ _ -> return ([], Just ())) (\_ _ -> fn)
 
+emitArtifacts :: [Artifact] -> Compile s ()
+emitArtifacts arts = Compile $ tell ([], arts)
+
 -- data IOActionExtraData = IOActionExtraData
 --   { parseFile :: FilePath -> IO (TreeType FiddleUnit Parsed),
 --     stage3Compile :: TreeType FiddleUnit Parsed ->
@@ -140,7 +167,7 @@ pureCompilationPhase fn =
 data CompilationPhase stageFrom stageTo where
   CompilationPhase ::
     forall privateFlags privateState stageFrom stageTo.
-    (CompilationStage stageFrom) =>
+    -- (CompilationStage stageFrom) =>
     { optionsParser :: Parser privateFlags,
       -- | 'ioAction' is an IO operation that runs after the ast is parsed. It
       -- takes the parsed 'FiddleUnit' and performs some side effect
@@ -211,6 +238,7 @@ execCompilationPipelineWithCmdline ::
     ( FiddleUnit Parsed Identity (StageAnnotation Parsed) ->
       IO
         ( [Diagnostic],
+          [Artifact],
           Maybe
             ( FiddleUnit s' Identity (StageAnnotation s')
             )
@@ -222,8 +250,8 @@ execCompilationPipelineWithCmdline
       ( \opts ast -> do
           (diags, ms) <- ioAct opts ast
           case ms of
-            Just s -> return $ first (diags ++) $ compile_ $ rest opts s ast
-            Nothing -> return (diags, Nothing)
+            Just s -> return $ (\(a, b, c) -> (diags ++ a, b, c)) $ compile_ $ rest opts s ast
+            Nothing -> return (diags, [], Nothing)
       )
       flagsParser
 
diff --git a/src/Language/Fiddle/Compiler/ImportResolution.hs b/src/Language/Fiddle/Compiler/ImportResolution.hs
index b475801..f3ddee0 100644
--- a/src/Language/Fiddle/Compiler/ImportResolution.hs
+++ b/src/Language/Fiddle/Compiler/ImportResolution.hs
@@ -8,16 +8,19 @@ module Language.Fiddle.Compiler.ImportResolution
   )
 where
 
+import qualified Codec.Compression.GZip as GZip
 import Control.Arrow (Arrow (second))
-import Control.Monad (filterM)
+import Control.Monad (filterM, when)
 import Control.Monad.Identity (Identity)
 import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT))
 import Control.Monad.Writer.Lazy (MonadTrans (lift), MonadWriter (tell), WriterT (..), execWriterT)
 import Data.Aeson (eitherDecode, encode)
+import qualified Data.ByteString.Lazy as BL
 import Data.Map (Map)
-import Data.Maybe (fromMaybe)
+import qualified Data.Map as Map
+import Data.Maybe (fromMaybe, isNothing)
 import Data.Text (Text)
-import Data.Tuple (swap)
+import qualified Data.Text as Text
 import Data.Typeable
 import Language.Fiddle.Ast
 import Language.Fiddle.Compiler
@@ -28,11 +31,7 @@ import Options.Applicative
 import System.Directory
 import System.FilePath
 import Text.Printf (printf)
-
-import qualified Codec.Compression.GZip as GZip
-import qualified Data.ByteString.Lazy as BL
-import qualified Data.Map as Map
-import qualified Data.Text as Text
+import Control.Monad.State (put)
 
 newtype Flags = Flags
   { importDirectories :: [FilePath]
@@ -52,16 +51,16 @@ parseFlags =
 
 importResolutionPhase ::
   ( FilePath ->
-    IO ([Diagnostic], Maybe (TreeType FiddleUnit Parsed))
+    IO ([Diagnostic], [Artifact], Maybe (TreeType FiddleUnit Parsed))
   ) ->
   ( TreeType FiddleUnit Parsed ->
-    IO ([Diagnostic], Maybe (TreeType FiddleUnit Checked))
+    IO ([Diagnostic], [Artifact], Maybe (TreeType FiddleUnit Checked))
   ) ->
   CompilationPhase CurrentStage ImportsResolved
 importResolutionPhase parseFile compileToChecked =
   CompilationPhase parseFlags (getImportResolutionState parseFile compileToChecked) resolveImports
 
-type GlobalState = ()
+type GlobalState = Bool
 
 type LocalState = ResolvedImports
 
@@ -90,7 +89,17 @@ resolveImports ::
   ResolvedImports ->
   FiddleUnit CurrentStage I Annot ->
   Compile () (FiddleUnit ImportsResolved I Annot)
-resolveImports _ = advanceStage
+resolveImports _ localState t = do
+  (b, a) <- subCompile False $ advanceStage localState t
+  if b
+    then compilationFailure
+    else return a
+
+-- | Mark the current compilation as failed, but allows the import resolution to
+-- continue in order to allow all import failures to be reported at the same
+-- time rather than as piecemeal.
+markFatal :: Compile Bool ()
+markFatal = put True
 
 deriving instance AdvanceStage CurrentStage ObjTypeBody
 
@@ -132,19 +141,21 @@ instance AdvanceStage CurrentStage ImportStatement where
     v <- case what of
       Nothing -> do
         emitDiagnosticError "Failed to lookup imports (This is a bug)" a
+        markFatal
         return empty
       Just (diags, val) -> do
         tell diags
+        when (isNothing val) markFatal
         return $ fromMaybe empty val
 
     return $ ImportStatement path list v a
 
 getImportResolutionState ::
   ( FilePath ->
-    IO ([Diagnostic], Maybe (TreeType FiddleUnit Parsed))
+    IO ([Diagnostic], [Artifact], Maybe (TreeType FiddleUnit Parsed))
   ) ->
   ( TreeType FiddleUnit Parsed ->
-    IO ([Diagnostic], Maybe (TreeType FiddleUnit Checked))
+    IO ([Diagnostic], [Artifact], Maybe (TreeType FiddleUnit Checked))
   ) ->
   Flags ->
   FiddleUnit CurrentStage Identity Annot ->
@@ -164,7 +175,7 @@ getImportResolutionState parseFile compileToChecked flags unit = do
           | Just
               (ImportStatement {importPath = path, importStatementAnnot = (unCommented -> a)}) <-
               castTS u -> do
-              (diagnostics, unitInterface) <-
+              (diagnostics, _, unitInterface) <-
                 lift $
                   ioGetImportInterface a (importDirectories flags) (Text.unpack path)
 
@@ -190,7 +201,7 @@ getImportResolutionState parseFile compileToChecked flags unit = do
         then (diags, Nothing)
         else (diags, a)
 
-    ioGetImportInterface :: SourceSpan -> [FilePath] -> FilePath -> IO ([Diagnostic], Maybe UnitInterface)
+    ioGetImportInterface :: SourceSpan -> [FilePath] -> FilePath -> IO ([Diagnostic], [Artifact], Maybe UnitInterface)
     ioGetImportInterface srcSpan imports fp = runCompl $ do
       path <- findFileInImportPath srcSpan imports fp
       let intf = interfaceFile path
@@ -212,8 +223,8 @@ getImportResolutionState parseFile compileToChecked flags unit = do
                 then doFullCompile
                 else return val
             Left err -> do
-              tell [Diagnostic Warning "Doing recompile" srcSpan]
-              tell [Diagnostic Warning err srcSpan]
+              tell ([Diagnostic Warning "Doing recompile" srcSpan], [])
+              tell ([Diagnostic Warning err srcSpan], [])
               doFullCompile
         else doFullCompile
 
@@ -254,23 +265,23 @@ getImportResolutionState parseFile compileToChecked flags unit = do
 
       case realPaths of
         [] -> do
-          lift $ tell [Diagnostic Error (printf "Cannot find %s on path" path) sourceSpan]
+          lift $ tell ([Diagnostic Error (printf "Cannot find %s on path" path) sourceSpan], [])
           MaybeT (return Nothing)
         (a : _) -> return a
 
-bump :: IO ([Diagnostic], Maybe a) -> Compl a
+bump :: IO ([Diagnostic], [Artifact], Maybe a) -> Compl a
 bump x = do
-  (diags, ma) <- lift2 x
-  lift $ tell diags
+  (diags, artifacts, ma) <- lift2 x
+  lift $ tell (diags, artifacts)
   MaybeT (return ma)
 
 lift2 :: (Monad m, MonadTrans t0, MonadTrans t1) => m a -> t0 (t1 m) a
 lift2 = lift . lift
 
-runCompl :: Compl a -> IO ([Diagnostic], Maybe a)
-runCompl c = swap <$> runWriterT (runMaybeT c)
+runCompl :: Compl a -> IO ([Diagnostic], [Artifact], Maybe a)
+runCompl c = (\(x, (y, z)) -> (y, z, x)) <$> runWriterT (runMaybeT c)
 
-type Compl a = MaybeT (WriterT [Diagnostic] IO) a
+type Compl a = MaybeT (WriterT ([Diagnostic], [Artifact]) IO) a
 
 allM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool
 allM _ [] = return True
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