git.iko.soy/Idris-dev
on fcb66ca help sign in
Idris-dev/src/Core/Execute.hs
526 lines 24 kB history raw
1{-# LANGUAGE PatternGuards, ExistentialQuantification #-}
2module Core.Execute (execute) where
4import Idris.AbsSyntax
5import Idris.AbsSyntaxTree
6import IRTS.Lang(FType(..))
8import Idris.Primitives(Prim(..), primitives)
10import Core.TT
11import Core.Evaluate
12import Core.CaseTree
14import Debug.Trace
16import Util.DynamicLinker
17import Util.System
19import Control.Applicative hiding (Const)
20import Control.Monad.Trans
21import Control.Monad.Trans.State.Strict
22import Control.Monad.Trans.Error
23import Control.Monad
24import Data.Maybe
25import Data.Bits
26import qualified Data.Map as M
28import Foreign.LibFFI
29import Foreign.C.String
30import Foreign.Marshal.Alloc (free)
31import Foreign.Ptr
33import System.IO
35readMay :: (Read a) => String -> Maybe a
36readMay s = case reads s of
37 [(x, "")] -> Just x
38 _ -> Nothing
40data Lazy = Delayed ExecEnv Context Term | Forced ExecVal deriving Show
42data ExecState = ExecState { exec_thunks :: M.Map Int Lazy -- ^ Thunks - the result of evaluating "lazy" or calling lazy funcs
43 , exec_next_thunk :: Int -- ^ Ensure thunk key uniqueness
44 , exec_implicits :: Ctxt [PArg] -- ^ Necessary info on laziness from idris monad
45 , exec_dynamic_libs :: [DynamicLib] -- ^ Dynamic libs from idris monad
46 }
48data ExecVal = EP NameType Name ExecVal
49 | EV Int
50 | EBind Name (Binder ExecVal) (ExecVal -> Exec ExecVal)
51 | EApp ExecVal ExecVal
52 | EType UExp
53 | EErased
54 | EConstant Const
55 | forall a. EPtr (Ptr a)
56 | EThunk Int
57 | EHandle Handle
59instance Show ExecVal where
60 show (EP _ n _) = show n
61 show (EV i) = "!!V" ++ show i ++ "!!"
62 show (EBind n b body) = "EBind " ++ show b ++ " <<fn>>"
63 show (EApp e1 e2) = show e1 ++ " (" ++ show e2 ++ ")"
64 show (EType _) = "Type"
65 show EErased = "[__]"
66 show (EConstant c) = show c
67 show (EPtr p) = "<<ptr " ++ show p ++ ">>"
68 show (EThunk i) = "<<thunk " ++ show i ++ ">>"
69 show (EHandle h) = "<<handle " ++ show h ++ ">>"
71toTT :: ExecVal -> Exec Term
72toTT (EP nt n ty) = (P nt n) <$> (toTT ty)
73toTT (EV i) = return $ V i
74toTT (EBind n b body) = do body' <- body $ EP Bound n EErased
75 b' <- fixBinder b
76 Bind n b' <$> toTT body'
77 where fixBinder (Lam t) = Lam <$> toTT t
78 fixBinder (Pi t) = Pi <$> toTT t
79 fixBinder (Let t1 t2) = Let <$> toTT t1 <*> toTT t2
80 fixBinder (NLet t1 t2) = NLet <$> toTT t1 <*> toTT t2
81 fixBinder (Hole t) = Hole <$> toTT t
82 fixBinder (GHole t) = GHole <$> toTT t
83 fixBinder (Guess t1 t2) = Guess <$> toTT t1 <*> toTT t2
84 fixBinder (PVar t) = PVar <$> toTT t
85 fixBinder (PVTy t) = PVTy <$> toTT t
86toTT (EApp e1 e2) = do e1' <- toTT e1
87 e2' <- toTT e2
88 return $ App e1' e2'
89toTT (EType u) = return $ TType u
90toTT EErased = return Erased
91toTT (EConstant c) = return (Constant c)
92toTT (EThunk i) = return (P (DCon 0 0) (MN i "THUNK") Erased) --(force i) >>= toTT
93toTT (EHandle _) = return Erased
95unApplyV :: ExecVal -> (ExecVal, [ExecVal])
96unApplyV tm = ua [] tm
97 where ua args (EApp f a) = ua (a:args) f
98 ua args t = (t, args)
100mkEApp :: ExecVal -> [ExecVal] -> ExecVal
101mkEApp f [] = f
102mkEApp f (a:args) = mkEApp (EApp f a) args
104initState :: Idris ExecState
105initState = do ist <- getIState
106 return $ ExecState M.empty 0 (idris_implicits ist) (idris_dynamic_libs ist)
108type Exec = ErrorT String (StateT ExecState IO)
110runExec :: Exec a -> ExecState -> IO (Either String a)
111runExec ex st = fst <$> runStateT (runErrorT ex) st
113getExecState :: Exec ExecState
114getExecState = lift get
116putExecState :: ExecState -> Exec ()
117putExecState = lift . put
119execFail :: String -> Exec a
120execFail = throwError
122execIO :: IO a -> Exec a
123execIO = lift . lift
125delay :: ExecEnv -> Context -> Term -> Exec ExecVal
126delay env ctxt tm =
127 do st <- getExecState
128 let i = exec_next_thunk st
129 putExecState $ st { exec_thunks = M.insert i (Delayed env ctxt tm) (exec_thunks st)
130 , exec_next_thunk = exec_next_thunk st + 1
131 }
132 return $ EThunk i
134force :: Int -> Exec ExecVal
135force i = do st <- getExecState
136 case M.lookup i (exec_thunks st) of
137 Just (Delayed env ctxt tm) -> do tm' <- doExec env ctxt tm
138 case tm' of
139 EThunk i ->
140 do res <- force i
141 update res i
142 return res
143 _ -> do update tm' i
144 return tm'
145 Just (Forced tm) -> return tm
146 Nothing -> execFail "Tried to exec non-existing thunk. This is a bug!"
147 where update :: ExecVal -> Int -> Exec ()
148 update tm i = do est <- getExecState
149 putExecState $ est { exec_thunks = M.insert i (Forced tm) (exec_thunks est) }
151tryForce :: ExecVal -> Exec ExecVal
152tryForce (EThunk i) = force i
153tryForce tm = return tm
155debugThunks :: Exec ()
156debugThunks = do st <- getExecState
157 execIO $ putStrLn (take 4000 (show (exec_thunks st)))
159execute :: Term -> Idris Term
160execute tm = do est <- initState
161 ctxt <- getContext
162 res <- lift $ flip runExec est $ do res <- doExec [] ctxt tm
163 toTT res
164 case res of
165 Left err -> fail err
166 Right tm' -> return tm'
168ioWrap :: ExecVal -> ExecVal
169ioWrap tm = mkEApp (EP (DCon 0 2) (UN "prim__IO") EErased) [EErased, tm]
171ioUnit :: ExecVal
172ioUnit = ioWrap (EP Ref unitCon EErased)
174type ExecEnv = [(Name, ExecVal)]
176doExec :: ExecEnv -> Context -> Term -> Exec ExecVal
177doExec env ctxt p@(P Ref n ty) | Just v <- lookup n env = return v
178doExec env ctxt p@(P Ref n ty) =
179 do let val = lookupDef n ctxt
180 case val of
181 [Function _ tm] -> doExec env ctxt tm
182 [TyDecl _ _] -> return (EP Ref n EErased) -- abstract def
183 [Operator tp arity op] -> return (EP Ref n EErased) -- will be special-cased later
184 [CaseOp _ _ _ _ _ [] (STerm tm) _ _] -> -- nullary fun
185 doExec env ctxt tm
186 [CaseOp _ _ _ _ _ ns sc _ _] -> return (EP Ref n EErased)
187 [] -> execFail $ "Could not find " ++ show n ++ " in definitions."
188 thing -> trace (take 200 $ "got to " ++ show thing ++ " lookup up " ++ show n) $ undefined
189doExec env ctxt p@(P Bound n ty) =
190 case lookup n env of
191 Nothing -> execFail "not found"
192 Just tm -> return tm
193doExec env ctxt (P (DCon a b) n _) = return (EP (DCon a b) n EErased)
194doExec env ctxt (P (TCon a b) n _) = return (EP (TCon a b) n EErased)
195doExec env ctxt v@(V i) | i < length env = return (snd (env !! i))
196 | otherwise = execFail "env too small"
197doExec env ctxt (Bind n (Let t v) body) = do v' <- doExec env ctxt v
198 doExec ((n, v'):env) ctxt body
199doExec env ctxt (Bind n (NLet t v) body) = trace "NLet" $ undefined
200doExec env ctxt tm@(Bind n b body) = return $
201 EBind n (fmap (\_->EErased) b)
202 (\arg -> doExec ((n, arg):env) ctxt body)
203doExec env ctxt a@(App _ _) = execApp env ctxt (unApply a)
204doExec env ctxt (Constant c) = return (EConstant c)
205doExec env ctxt (Proj tm i) = let (x, xs) = unApply tm in
206 doExec env ctxt ((x:xs) !! i)
207doExec env ctxt Erased = return EErased
208doExec env ctxt Impossible = fail "Tried to execute an impossible case"
209doExec env ctxt (TType u) = return (EType u)
211execApp :: ExecEnv -> Context -> (Term, [Term]) -> Exec ExecVal
212execApp env ctxt (f, args) = do newF <- doExec env ctxt f
213 laziness <- (++ repeat False) <$> (getLaziness newF)
214 newArgs <- mapM argExec (zip args laziness)
215 execApp' env ctxt newF newArgs
216 where getLaziness (EP _ (UN "lazy") _) = return [False, True]
217 getLaziness (EP _ n _) = do est <- getExecState
218 let argInfo = exec_implicits est
219 case lookupCtxtName n argInfo of
220 [] -> return (repeat False)
221 [ps] -> return $ map lazyarg (snd ps)
222 many -> execFail $ "Ambiguous " ++ show n ++ ", found " ++ (take 200 $ show many)
223 getLaziness _ = return (repeat False) -- ok due to zip above
224 argExec :: (Term, Bool) -> Exec ExecVal
225 argExec (tm, False) = doExec env ctxt tm
226 argExec (tm, True) = delay env ctxt tm
229execApp' :: ExecEnv -> Context -> ExecVal -> [ExecVal] -> Exec ExecVal
230execApp' env ctxt v [] = return v -- no args is just a constant! can result from function calls
231execApp' env ctxt (EP _ (UN "unsafePerformIO") _) (ty:action:rest) | (prim__IO, [_, v]) <- unApplyV action =
232 execApp' env ctxt v rest
234execApp' env ctxt (EP _ (UN "io_bind") _) args@(_:_:v:k:rest) | (prim__IO, [_, v']) <- unApplyV v =
235 do v'' <- tryForce v'
236 res <- execApp' env ctxt k [v''] >>= tryForce
237 execApp' env ctxt res rest
238execApp' env ctxt con@(EP _ (UN "io_return") _) args@(tp:v:rest) =
239 do v' <- tryForce v
240 execApp' env ctxt (mkEApp con [tp, v']) rest
242-- Special cases arising from not having access to the C RTS in the interpreter
243execApp' env ctxt (EP _ (UN "mkForeign") _) (_:fn:EConstant (Str arg):rest)
244 | Just (FFun "putStr" _ _) <- foreignFromTT fn = do execIO (putStr arg)
245 execApp' env ctxt ioUnit rest
246execApp' env ctxt (EP _ (UN "mkForeign") _) (_:fn:EConstant (Str f):EConstant (Str mode):rest)
247 | Just (FFun "fileOpen" _ _) <- foreignFromTT fn = do m <- case mode of
248 "r" -> return ReadMode
249 "w" -> return WriteMode
250 "a" -> return AppendMode
251 "rw" -> return ReadWriteMode
252 "wr" -> return ReadWriteMode
253 "r+" -> return ReadWriteMode
254 _ -> execFail ("Invalid mode for " ++ f ++ ": " ++ mode)
255 h <- execIO $ openFile f m
256 execApp' env ctxt (ioWrap (EHandle h)) rest
258execApp' env ctxt (EP _ (UN "mkForeign") _) (_:fn:(EHandle h):rest)
259 | Just (FFun "fileEOF" _ _) <- foreignFromTT fn = do eofp <- execIO $ hIsEOF h
260 let res = ioWrap (EConstant (I $ if eofp then 1 else 0))
261 execApp' env ctxt res rest
263execApp' env ctxt (EP _ (UN "mkForeign") _) (_:fn:(EHandle h):rest)
264 | Just (FFun "fileClose" _ _) <- foreignFromTT fn = do execIO $ hClose h
265 execApp' env ctxt ioUnit rest
267execApp' env ctxt (EP _ (UN "mkForeign") _) (_:fn:(EPtr p):rest)
268 | Just (FFun "isNull" _ _) <- foreignFromTT fn = let res = ioWrap . EConstant . I $
269 if p == nullPtr then 1 else 0
270 in execApp' env ctxt res rest
272execApp' env ctxt f@(EP _ (UN "mkForeign") _) args@(ty:fn:xs) | Just (FFun f argTs retT) <- foreignFromTT fn
273 , length xs >= length argTs =
274 do res <- stepForeign (ty:fn:take (length argTs) xs)
275 case res of
276 Nothing -> fail $ "Could not call foreign function \"" ++ f ++
277 "\" with args " ++ show (take (length argTs) xs)
278 Just r -> return (mkEApp r (drop (length argTs) xs))
279 | otherwise = return (mkEApp f args)
281execApp' env ctxt c@(EP (DCon _ arity) n _) args =
282 do args' <- mapM tryForce (take arity args)
283 let restArgs = drop arity args
284 execApp' env ctxt (mkEApp c args') restArgs
286execApp' env ctxt c@(EP (TCon _ arity) n _) args =
287 do args' <- mapM tryForce (take arity args)
288 let restArgs = drop arity args
289 execApp' env ctxt (mkEApp c args') restArgs
291execApp' env ctxt f@(EP _ n _) args =
292 do let val = lookupDef n ctxt
293 case val of
294 [Function _ tm] -> fail "should already have been eval'd"
295 [TyDecl nt ty] -> return $ mkEApp f args
296 [Operator tp arity op] ->
297 if length args >= arity
298 then do args' <- mapM tryForce $ take arity args
299 case getOp n args' of
300 Just res -> do r <- res
301 execApp' env ctxt r (drop arity args)
302 Nothing -> return (mkEApp f args)
303 else return (mkEApp f args)
304 [CaseOp _ _ _ _ _ [] (STerm tm) _ _] -> -- nullary fun
305 do rhs <- doExec env ctxt tm
306 execApp' env ctxt rhs args
307 [CaseOp _ _ _ _ _ ns sc _ _] ->
308 do res <- execCase env ctxt ns sc args
309 return $ fromMaybe (mkEApp f args) res
310 thing -> return $ mkEApp f args
311execApp' env ctxt bnd@(EBind n b body) (arg:args) = do ret <- body arg
312 let (f', as) = unApplyV ret
313 execApp' env ctxt f' (as ++ args)
314execApp' env ctxt (EThunk i) args = do f <- force i
315 execApp' env ctxt f args
316execApp' env ctxt app@(EApp _ _) args2 | (f, args1) <- unApplyV app = execApp' env ctxt f (args1 ++ args2)
317execApp' env ctxt f args = return (mkEApp f args)
319-- | Look up primitive operations in the global table and transform them into ExecVal functions
320getOp :: Name -> [ExecVal] -> Maybe (Exec ExecVal)
321getOp (UN "prim__believe_me") [_, _, x] = Just (return x)
322getOp (UN "prim__readString") [EP _ (UN "prim__stdin") _] =
323 Just $ do line <- execIO getLine
324 return (EConstant (Str line))
325getOp (UN "prim__readString") [EHandle h] =
326 Just $ do contents <- execIO $ hGetLine h
327 return (EConstant (Str (contents ++ "\n")))
328getOp n args = getPrim n primitives >>= flip applyPrim args
329 where getPrim :: Name -> [Prim] -> Maybe ([ExecVal] -> Maybe ExecVal)
330 getPrim n [] = Nothing
331 getPrim n ((Prim pn _ arity def _ _) : prims) | n == pn = Just $ execPrim def
332 | otherwise = getPrim n prims
334 execPrim :: ([Const] -> Maybe Const) -> [ExecVal] -> Maybe ExecVal
335 execPrim f args = EConstant <$> (mapM getConst args >>= f)
337 getConst (EConstant c) = Just c
338 getConst _ = Nothing
340 applyPrim :: ([ExecVal] -> Maybe ExecVal) -> [ExecVal] -> Maybe (Exec ExecVal)
341 applyPrim fn args = return <$> fn args
346-- | Overall wrapper for case tree execution. If there are enough arguments, it takes them,
347-- evaluates them, then begins the checks for matching cases.
348execCase :: ExecEnv -> Context -> [Name] -> SC -> [ExecVal] -> Exec (Maybe ExecVal)
349execCase env ctxt ns sc args =
350 let arity = length ns in
351 if arity <= length args
352 then do let amap = zip ns args
353-- trace ("Case " ++ show sc ++ "\n in " ++ show amap ++"\n in env " ++ show env ++ "\n\n" ) $ return ()
354 caseRes <- execCase' env ctxt amap sc
355 case caseRes of
356 Just res -> Just <$> execApp' (map (\(n, tm) -> (n, tm)) amap ++ env) ctxt res (drop arity args)
357 Nothing -> return Nothing
358 else return Nothing
360-- | Take bindings and a case tree and examines them, executing the matching case if possible.
361execCase' :: ExecEnv -> Context -> [(Name, ExecVal)] -> SC -> Exec (Maybe ExecVal)
362execCase' env ctxt amap (UnmatchedCase _) = return Nothing
363execCase' env ctxt amap (STerm tm) =
364 Just <$> doExec (map (\(n, v) -> (n, v)) amap ++ env) ctxt tm
365execCase' env ctxt amap (Case n alts) | Just tm <- lookup n amap =
366 do tm' <- tryForce tm
367 case chooseAlt tm' alts of
368 Just (newCase, newBindings) ->
369 let amap' = newBindings ++ (filter (\(x,_) -> not (elem x (map fst newBindings))) amap) in
370 execCase' env ctxt amap' newCase
371 Nothing -> return Nothing
373chooseAlt :: ExecVal -> [CaseAlt] -> Maybe (SC, [(Name, ExecVal)])
374chooseAlt _ (DefaultCase sc : alts) = Just (sc, [])
375chooseAlt (EConstant c) (ConstCase c' sc : alts) | c == c' = Just (sc, [])
376chooseAlt tm (ConCase n i ns sc : alts) | ((EP _ cn _), args) <- unApplyV tm
377 , cn == n = Just (sc, zip ns args)
378 | otherwise = chooseAlt tm alts
379chooseAlt tm (_:alts) = chooseAlt tm alts
380chooseAlt _ [] = Nothing
385idrisType :: FType -> ExecVal
386idrisType FUnit = EP Ref unitTy EErased
387idrisType ft = EConstant (idr ft)
388 where idr (FArith ty) = AType ty
389 idr FString = StrType
390 idr FPtr = PtrType
392data Foreign = FFun String [FType] FType deriving Show
395call :: Foreign -> [ExecVal] -> Exec (Maybe ExecVal)
396call (FFun name argTypes retType) args =
397 do fn <- findForeign name
398 case fn of
399 Nothing -> return Nothing
400 Just f -> do res <- call' f args retType
401 return . Just . ioWrap $ res
402 where call' :: ForeignFun -> [ExecVal] -> FType -> Exec ExecVal
403 call' (Fun _ h) args (FArith (ATInt ITNative)) = do
404 res <- execIO $ callFFI h retCInt (prepArgs args)
405 return (EConstant (I (fromIntegral res)))
406 call' (Fun _ h) args (FArith (ATInt (ITFixed IT8))) = do
407 res <- execIO $ callFFI h retCChar (prepArgs args)
408 return (EConstant (B8 (fromIntegral res)))
409 call' (Fun _ h) args (FArith (ATInt (ITFixed IT16))) = do
410 res <- execIO $ callFFI h retCWchar (prepArgs args)
411 return (EConstant (B16 (fromIntegral res)))
412 call' (Fun _ h) args (FArith (ATInt (ITFixed IT32))) = do
413 res <- execIO $ callFFI h retCInt (prepArgs args)
414 return (EConstant (B32 (fromIntegral res)))
415 call' (Fun _ h) args (FArith (ATInt (ITFixed IT64))) = do
416 res <- execIO $ callFFI h retCLong (prepArgs args)
417 return (EConstant (B64 (fromIntegral res)))
418 call' (Fun _ h) args (FArith ATFloat) = do
419 res <- execIO $ callFFI h retCDouble (prepArgs args)
420 return (EConstant (Fl (realToFrac res)))
421 call' (Fun _ h) args (FArith (ATInt ITChar)) = do
422 res <- execIO $ callFFI h retCChar (prepArgs args)
423 return (EConstant (Ch (castCCharToChar res)))
424 call' (Fun _ h) args FString = do res <- execIO $ callFFI h retCString (prepArgs args)
425 hStr <- execIO $ peekCString res
426-- lift $ free res
427 return (EConstant (Str hStr))
429 call' (Fun _ h) args FPtr = do res <- execIO $ callFFI h (retPtr retVoid) (prepArgs args)
430 return (EPtr res)
431 call' (Fun _ h) args FUnit = do res <- execIO $ callFFI h retVoid (prepArgs args)
432 return (EP Ref unitCon EErased)
433-- call' (Fun _ h) args other = fail ("Unsupported foreign return type " ++ show other)
436 prepArgs = map prepArg
437 prepArg (EConstant (I i)) = argCInt (fromIntegral i)
438 prepArg (EConstant (B8 i)) = argCChar (fromIntegral i)
439 prepArg (EConstant (B16 i)) = argCWchar (fromIntegral i)
440 prepArg (EConstant (B32 i)) = argCInt (fromIntegral i)
441 prepArg (EConstant (B64 i)) = argCLong (fromIntegral i)
442 prepArg (EConstant (Fl f)) = argCDouble (realToFrac f)
443 prepArg (EConstant (Ch c)) = argCChar (castCharToCChar c) -- FIXME - castCharToCChar only safe for first 256 chars
444 prepArg (EConstant (Str s)) = argString s
445 prepArg (EPtr p) = argPtr p
446 prepArg other = trace ("Could not use " ++ take 100 (show other) ++ " as FFI arg.") undefined
450foreignFromTT :: ExecVal -> Maybe Foreign
451foreignFromTT t = case (unApplyV t) of
452 (_, [(EConstant (Str name)), args, ret]) ->
453 do argTy <- unEList args
454 argFTy <- sequence $ map getFTy argTy
455 retFTy <- getFTy ret
456 return $ FFun name argFTy retFTy
457 _ -> trace "failed to construct ffun" Nothing
459getFTy :: ExecVal -> Maybe FType
460getFTy (EApp (EP _ (UN "FIntT") _) (EP _ (UN intTy) _)) =
461 case intTy of
462 "ITNative" -> Just (FArith (ATInt ITNative))
463 "ITChar" -> Just (FArith (ATInt ITChar))
464 "IT8" -> Just (FArith (ATInt (ITFixed IT8)))
465 "IT16" -> Just (FArith (ATInt (ITFixed IT16)))
466 "IT32" -> Just (FArith (ATInt (ITFixed IT32)))
467 "IT64" -> Just (FArith (ATInt (ITFixed IT64)))
468 _ -> Nothing
469getFTy (EP _ (UN t) _) =
470 case t of
471 "FFloat" -> Just (FArith ATFloat)
472 "FString" -> Just FString
473 "FPtr" -> Just FPtr
474 "FUnit" -> Just FUnit
475 _ -> Nothing
476getFTy _ = Nothing
478unList :: Term -> Maybe [Term]
479unList tm = case unApply tm of
480 (nil, [_]) -> Just []
481 (cons, ([_, x, xs])) ->
482 do rest <- unList xs
483 return $ x:rest
484 (f, args) -> Nothing
486unEList :: ExecVal -> Maybe [ExecVal]
487unEList tm = case unApplyV tm of
488 (nil, [_]) -> Just []
489 (cons, ([_, x, xs])) ->
490 do rest <- unEList xs
491 return $ x:rest
492 (f, args) -> Nothing
495toConst :: Term -> Maybe Const
496toConst (Constant c) = Just c
497toConst _ = Nothing
499stepForeign :: [ExecVal] -> Exec (Maybe ExecVal)
500stepForeign (ty:fn:args) = do let ffun = foreignFromTT fn
501 f' <- case (call <$> ffun) of
502 Just f -> f args
503 Nothing -> return Nothing
504 return f'
505stepForeign _ = fail "Tried to call foreign function that wasn't mkForeign"
507mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]
508mapMaybeM f [] = return []
509mapMaybeM f (x:xs) = do rest <- mapMaybeM f xs
510 x' <- f x
511 case x' of
512 Just x'' -> return (x'':rest)
513 Nothing -> return rest
515findForeign :: String -> Exec (Maybe ForeignFun)
516findForeign fn = do est <- getExecState
517 let libs = exec_dynamic_libs est
518 fns <- mapMaybeM getFn libs
519 case fns of
520 [f] -> return (Just f)
521 [] -> do execIO . putStrLn $ "Symbol \"" ++ fn ++ "\" not found"
522 return Nothing
523 fs -> do execIO . putStrLn $ "Symbol \"" ++ fn ++ "\" is ambiguous. Found " ++
524 show (length fs) ++ " occurrences."
525 return Nothing
526 where getFn lib = execIO $ catchIO (tryLoadFn fn lib) (\_ -> return Nothing)