diff --git a/cogent/Main.hs b/cogent/Main.hs index 686856d25..ad16c83de 100644 --- a/cogent/Main.hs +++ b/cogent/Main.hs @@ -696,7 +696,7 @@ parseArgs args = case getOpt' Permute options args of let stg = STGNormal putProgress "Normalising..." nfed' <- case __cogent_fnormalisation of - NoNF -> putProgressLn "Skipped" >> return desugared + NoNF -> putProgressLn "Skipped." >> return desugared nf -> do putProgressLn (show nf) let nfed = NF.normal $ map untypeD desugared if not $ verifyNormal nfed @@ -794,15 +794,17 @@ parseArgs args = case getOpt' Permute options args of hscName = mkOutputName' toHsModName source (Just __cogent_suffix_of_ffi_types) hsName = mkOutputName' toHsModName source (Just __cogent_suffix_of_ffi) cNames = map (\n -> takeBaseName n ++ __cogent_suffix_of_pp ++ __cogent_suffix_of_inferred <.> __cogent_ext_of_c) __cogent_infer_c_func_files - cacheFile = __cogent_name_cache - cacheExists <- doesFileExist __cogent_name_cache - if cacheExists then putProgressLn ("Using existing name cache file: " ++ __cogent_name_cache) - else putProgressLn ("No name cache file found: " ++ __cogent_name_cache) - mcache <- if cacheExists then do decodeResult <- decodeFileOrFail __cogent_name_cache - case decodeResult of - Left (_, err) -> hPutStrLn stderr ("Decoding name cache file failed: " ++ err) >> exitFailure - Right cache -> return $ Just cache - else return Nothing + (mcache, decodingFailed) <- case __cogent_name_cache of + Nothing -> return (Nothing, False) + Just cacheFile -> do + cacheExists <- doesFileExist cacheFile + if not cacheExists + then putProgressLn ("No name cache file found: " ++ cacheFile) >> return (Nothing, False) + else do putProgressLn ("Using existing name cache file: " ++ cacheFile) + decodeResult <- decodeFileOrFail cacheFile + case decodeResult of + Left (_, err) -> hPutStrLn stderr ("Decoding name cache file failed: " ++ err ++ ".\nNot using name cache.") >> return (Nothing, True) + Right cache -> return (Just cache, False) let (h,c,atm,ct,hsc,hs,genst) = cgen hName cNames hscName hsName monoed mcache ctygen log when (TableAbsTypeMono `elem` cmds) $ do let atmfile = mkFileName source Nothing __cogent_ext_of_atm @@ -835,8 +837,10 @@ parseArgs args = case getOpt' Permute options args of output cf $ flip M.hPutDoc (ppr c M.line) -- .c file gen unless (null $ __cogent_infer_c_func_files ++ __cogent_infer_c_type_files) $ glue cmds tced tcst typedefs fts insts genst buildinfo log - putProgressLn ("Writing name cache file: " ++ __cogent_name_cache) - encodeFile __cogent_name_cache genst + forM_ __cogent_name_cache $ \cacheFile -> do + unless decodingFailed $ do + putProgressLn ("Writing name cache file: " ++ cacheFile) + encodeFile cacheFile genst c_refinement source monoed insts log (False,False,False) = return () c_refinement source monoed insts log (ac,cs,cp) = do diff --git a/cogent/src/Cogent/Compiler.hs b/cogent/src/Cogent/Compiler.hs index 025b3fc82..a913127ea 100644 --- a/cogent/src/Cogent/Compiler.hs +++ b/cogent/src/Cogent/Compiler.hs @@ -182,7 +182,7 @@ set_flag_fwrapPutInLet = writeIORef __cogent_fwrap_put_in_let_ref True set_flag_inferCFunc = writeIORef __cogent_infer_c_func_files_ref set_flag_inferCType = writeIORef __cogent_infer_c_type_files_ref set_flag_interactive = writeIORef __cogent_interactive_ref True -set_flag_nameCache = writeIORef __cogent_name_cache_ref +set_flag_nameCache = writeIORef __cogent_name_cache_ref . Just set_flag_O Nothing = return () set_flag_O (Just n :: Maybe String) | n == "0" = do set_flag_fnormalisation Nothing @@ -661,12 +661,12 @@ __cogent_interactive_ref :: IORef Bool {-# NOINLINE __cogent_interactive_ref #-} __cogent_interactive_ref = unsafePerformIO $ newIORef False -__cogent_name_cache :: FilePath +__cogent_name_cache :: Maybe FilePath __cogent_name_cache = unsafePerformIO $ readIORef __cogent_name_cache_ref -__cogent_name_cache_ref :: IORef FilePath +__cogent_name_cache_ref :: IORef (Maybe FilePath) {-# NOINLINE __cogent_name_cache_ref #-} -__cogent_name_cache_ref = unsafePerformIO $ newIORef ".name-cache" +__cogent_name_cache_ref = unsafePerformIO $ newIORef Nothing __cogent_output_name :: Maybe String __cogent_output_name = unsafePerformIO $ readIORef __cogent_output_name_ref