diff --git a/cryptol-remote-api/src/CryptolServer/FileDeps.hs b/cryptol-remote-api/src/CryptolServer/FileDeps.hs index db8edc238..0318badf0 100644 --- a/cryptol-remote-api/src/CryptolServer/FileDeps.hs +++ b/cryptol-remote-api/src/CryptolServer/FileDeps.hs @@ -7,6 +7,7 @@ module CryptolServer.FileDeps ) where import Data.Text (Text) +import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Aeson as JSON @@ -68,7 +69,7 @@ instance ToJSON FileDeps where , "fingerprint" .= fingerprintHexString (fiFingerprint fi) , "includes" .= Set.toList (fiIncludeDeps fi) , "imports" .= map (show . pp) (Set.toList (fiImportDeps fi)) - , "foreign" .= Set.toList (fiForeignDeps fi) + , "foreign" .= Map.toList (fiForeignDeps fi) ] where fi = fdInfo fd diff --git a/src/Cryptol/Backend/FFI.hs b/src/Cryptol/Backend/FFI.hs index 9330b3aae..0ad7059ae 100644 --- a/src/Cryptol/Backend/FFI.hs +++ b/src/Cryptol/Backend/FFI.hs @@ -6,6 +6,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} -- | The implementation of loading and calling external functions from shared @@ -37,12 +38,13 @@ import Control.Concurrent.MVar import Control.Exception import Control.Monad import Data.Bifunctor +import Data.Maybe import Data.Word import Foreign hiding (newForeignPtr) import Foreign.C.Types import Foreign.Concurrent import Foreign.LibFFI -import System.Directory (doesFileExist, canonicalizePath) +import System.Directory (canonicalizePath, doesFileExist) import System.FilePath ((-<.>)) import System.Info (os) import System.IO.Error @@ -98,19 +100,22 @@ loadForeignSrc = loadForeignLib >=> traverse \(foreignSrcPath, ptr) -> do pure ForeignSrc {..} --- | Given the path to a Cryptol module, compute the location of --- the shared library we'd like to load. -foreignLibPath :: FilePath -> IO (Maybe FilePath) +-- | Given the path to a Cryptol module, compute the location of the shared +-- library we'd like to load. If FFI is supported, returns the location and +-- whether or not it actually exists on disk. Otherwise, returns Nothing. +foreignLibPath :: FilePath -> IO (Maybe (FilePath, Bool)) foreignLibPath path = do path' <- canonicalizePath path - let search es = - case es of - [] -> pure Nothing - e : more -> do - let p = path' -<.> e + let libPaths = map (path' -<.>) exts + search ps = + case ps of + [] -> pure ((, False) <$> listToMaybe libPaths) + p : more -> do yes <- doesFileExist p - if yes then pure (Just p) else search more - search + if yes then pure (Just (p, True)) else search more + search libPaths + where + exts = case os of "mingw32" -> ["dll"] "darwin" -> ["dylib","so"] @@ -120,8 +125,10 @@ loadForeignLib :: FilePath -> IO (Either FFILoadError (FilePath, Ptr ())) loadForeignLib path = do mb <- foreignLibPath path case mb of - Nothing -> pure (Left (CantLoadFFISrc path "File not found")) - Just libPath -> tryLoad (CantLoadFFISrc path) (open libPath) + Just (libPath, True) -> + tryLoad (CantLoadFFISrc path) (open libPath) + _ -> + pure (Left (CantLoadFFISrc path "File not found")) where open libPath = do #if defined(mingw32_HOST_OS) @@ -271,7 +278,7 @@ loadForeignSrc _ = pure $ Right ForeignSrc unloadForeignSrc :: ForeignSrc -> IO () unloadForeignSrc _ = pure () -foreignLibPath :: FilePath -> IO (Maybe FilePath) +foreignLibPath :: FilePath -> IO (Maybe (FilePath, Bool)) foreignLibPath _ = pure Nothing #endif diff --git a/src/Cryptol/Eval.hs b/src/Cryptol/Eval.hs index 37176159c..4b7d7e85d 100644 --- a/src/Cryptol/Eval.hs +++ b/src/Cryptol/Eval.hs @@ -487,11 +487,11 @@ evalDecl sym renv env d = do DForeign _ me -> do -- Foreign declarations should have been handled by the previous -- Cryptol.Eval.FFI.evalForeignDecls pass already, so they should already - -- be in the environment. If not, then either Cryptol was not compiled - -- with FFI support enabled, or we are in a non-Concrete backend. In that - -- case, we bind the name to the fallback cryptol implementation if - -- present, or otherwise to an error computation which will raise an error - -- if we try to evaluate it. + -- be in the environment. If not, then either the foreign source was + -- missing, Cryptol was not compiled with FFI support enabled, or we are + -- in a non-Concrete backend. In that case, we bind the name to the + -- fallback cryptol implementation if present, or otherwise to an error + -- computation which will raise an error if we try to evaluate it. case lookupVar (dName d) env of Just _ -> pure env Nothing -> bindVar sym (dName d) val env diff --git a/src/Cryptol/ModuleSystem/Base.hs b/src/Cryptol/ModuleSystem/Base.hs index 553ebe8a6..ae6fe08aa 100644 --- a/src/Cryptol/ModuleSystem/Base.hs +++ b/src/Cryptol/ModuleSystem/Base.hs @@ -451,21 +451,22 @@ findDepsOf :: ModulePath -> ModuleM (ModulePath, FileInfo) findDepsOf mpath = do (fp, incs, ms) <- parseModule mpath let (anyF,imps) = mconcat (map (findDeps' . addPrelude) ms) - fpath <- if getAny anyF + fdeps <- if getAny anyF then do mb <- io case mpath of InFile path -> foreignLibPath path InMem {} -> pure Nothing pure case mb of - Nothing -> Set.empty - Just f -> Set.singleton f - else pure Set.empty + Nothing -> Map.empty + Just (fpath, exists) -> + Map.singleton fpath exists + else pure Map.empty pure ( mpath , FileInfo { fiFingerprint = fp , fiIncludeDeps = incs , fiImportDeps = Set.fromList (map importedModule (appEndo imps [])) - , fiForeignDeps = fpath + , fiForeignDeps = fdeps } ) diff --git a/src/Cryptol/ModuleSystem/Env.hs b/src/Cryptol/ModuleSystem/Env.hs index 6678843a4..e2a34e9d7 100644 --- a/src/Cryptol/ModuleSystem/Env.hs +++ b/src/Cryptol/ModuleSystem/Env.hs @@ -564,7 +564,7 @@ data FileInfo = FileInfo { fiFingerprint :: Fingerprint , fiIncludeDeps :: Set FilePath , fiImportDeps :: Set ModName - , fiForeignDeps :: Set FilePath + , fiForeignDeps :: Map FilePath Bool } deriving (Show,Generic,NFData) @@ -579,9 +579,10 @@ fileInfo fp incDeps impDeps fsrc = { fiFingerprint = fp , fiIncludeDeps = incDeps , fiImportDeps = impDeps - , fiForeignDeps = fromMaybe Set.empty + , fiForeignDeps = fromMaybe Map.empty do src <- fsrc - Set.singleton <$> getForeignSrcPath src + fpath <- getForeignSrcPath src + pure $ Map.singleton fpath True } diff --git a/src/Cryptol/REPL/Command.hs b/src/Cryptol/REPL/Command.hs index 79d0bc7f9..7f0d43120 100644 --- a/src/Cryptol/REPL/Command.hs +++ b/src/Cryptol/REPL/Command.hs @@ -121,6 +121,7 @@ import Data.Bits (shiftL, (.&.), (.|.)) import Data.Char (isSpace,isPunctuation,isSymbol,isAlphaNum,isAscii) import Data.Function (on) import Data.List (intercalate, nub, isPrefixOf) +import qualified Data.Map as Map import Data.Maybe (fromMaybe,mapMaybe,isNothing) import System.Environment (lookupEnv) import System.Exit (ExitCode(ExitSuccess)) @@ -1823,7 +1824,7 @@ moduleInfoCmd isFile name depList show "includes" (Set.toList (M.fiIncludeDeps fi)) depList (show . show . pp) "imports" (Set.toList (M.fiImportDeps fi)) - depList show "foreign" (Set.toList (M.fiForeignDeps fi)) + depList show "foreign" (Map.toList (M.fiForeignDeps fi)) rPutStrLn "}"