diff options
Diffstat (limited to 'src/Language/Fiddle/Compiler/ImportResolution.hs')
| -rw-r--r-- | src/Language/Fiddle/Compiler/ImportResolution.hs | 61 |
1 files changed, 36 insertions, 25 deletions
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 |