git.iko.soy/Idris-dev
on fadeecd 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( IntTy(..)
7 , intTyToConst
8 , FType(..))
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 qualified Data.Map as M
27import Foreign.LibFFI
28import Foreign.C.String
29import Foreign.Marshal.Alloc (free)
30import Foreign.Ptr
32import System.IO
35data Lazy = Delayed ExecEnv Context Term | Forced ExecVal deriving Show
37data ExecState = ExecState { exec_thunks :: M.Map Int Lazy -- ^ Thunks - the result of evaluating "lazy" or calling lazy funcs
38 , exec_next_thunk :: Int -- ^ Ensure thunk key uniqueness
39 , exec_implicits :: Ctxt [PArg] -- ^ Necessary info on laziness from idris monad
40 , exec_dynamic_libs :: [DynamicLib] -- ^ Dynamic libs from idris monad
41 }
43data ExecVal = EP NameType Name ExecVal
44 | EV Int
45 | EBind Name (Binder ExecVal) (ExecVal -> Exec ExecVal)
46 | EApp ExecVal ExecVal
47 | EType UExp
48 | EErased
49 | EConstant Const
50 | forall a. EPtr (Ptr a)
51 | EThunk Int
52 | EHandle Handle
54instance Show ExecVal where
55 show (EP _ n _) = show n
56 show (EV i) = "!!V" ++ show i ++ "!!"
57 show (EBind n b body) = "EBind " ++ show b ++ " <<fn>>"
58 show (EApp e1 e2) = show e1 ++ " (" ++ show e2 ++ ")"
59 show (EType _) = "Type"
60 show EErased = "[__]"
61 show (EConstant c) = show c
62 show (EPtr p) = "<<ptr " ++ show p ++ ">>"
63 show (EThunk i) = "<<thunk " ++ show i ++ ">>"
64 show (EHandle h) = "<<handle " ++ show h ++ ">>"
66toTT :: ExecVal -> Exec Term
67toTT (EP nt n ty) = (P nt n) <$> (toTT ty)
68toTT (EV i) = return $ V i
69toTT (EBind n b body) = do body' <- body $ EP Bound n EErased
70 b' <- fixBinder b
71 Bind n b' <$> toTT body'
72 where fixBinder (Lam t) = Lam <$> toTT t
73 fixBinder (Pi t) = Pi <$> toTT t
74 fixBinder (Let t1 t2) = Let <$> toTT t1 <*> toTT t2
75 fixBinder (NLet t1 t2) = NLet <$> toTT t1 <*> toTT t2
76 fixBinder (Hole t) = Hole <$> toTT t
77 fixBinder (GHole t) = GHole <$> toTT t
78 fixBinder (Guess t1 t2) = Guess <$> toTT t1 <*> toTT t2
79 fixBinder (PVar t) = PVar <$> toTT t
80 fixBinder (PVTy t) = PVTy <$> toTT t
81toTT (EApp e1 e2) = do e1' <- toTT e1
82 e2' <- toTT e2
83 return $ App e1' e2'
84toTT (EType u) = return $ TType u
85toTT EErased = return Erased
86toTT (EConstant c) = return (Constant c)
87toTT (EThunk i) = return (P (DCon 0 0) (MN i "THUNK") Erased) --(force i) >>= toTT
88toTT (EHandle _) = return Erased
90unApplyV :: ExecVal -> (ExecVal, [ExecVal])
91unApplyV tm = ua [] tm
92 where ua args (EApp f a) = ua (a:args) f
93 ua args t = (t, args)
95mkEApp :: ExecVal -> [ExecVal] -> ExecVal
96mkEApp f [] = f
97mkEApp f (a:args) = mkEApp (EApp f a) args
99initState :: Idris ExecState
100initState = do ist <- getIState
101 return $ ExecState M.empty 0 (idris_implicits ist) (idris_dynamic_libs ist)
103type Exec = ErrorT String (StateT ExecState IO)
105runExec :: Exec a -> ExecState -> IO (Either String a)
106runExec ex st = fst <$> runStateT (runErrorT ex) st
108getExecState :: Exec ExecState
109getExecState = lift get
111putExecState :: ExecState -> Exec ()
112putExecState = lift . put
114execFail :: String -> Exec a
115execFail = throwError
117execIO :: IO a -> Exec a
118execIO = lift . lift
120delay :: ExecEnv -> Context -> Term -> Exec ExecVal
121delay env ctxt tm =
122 do st <- getExecState
123 let i = exec_next_thunk st
124 putExecState $ st { exec_thunks = M.insert i (Delayed env ctxt tm) (exec_thunks st)
125 , exec_next_thunk = exec_next_thunk st + 1
126 }
127 return $ EThunk i
129force :: Int -> Exec ExecVal
130force i = do st <- getExecState
131 case M.lookup i (exec_thunks st) of
132 Just (Delayed env ctxt tm) -> do tm' <- doExec env ctxt tm
133 case tm' of
134 EThunk i ->
135 do res <- force i
136 update res i
137 return res
138 _ -> do update tm' i
139 return tm'
140 Just (Forced tm) -> return tm
141 Nothing -> execFail "Tried to exec non-existing thunk. This is a bug!"
142 where update :: ExecVal -> Int -> Exec ()
143 update tm i = do est <- getExecState
144 putExecState $ est { exec_thunks = M.insert i (Forced tm) (exec_thunks est) }
146tryForce :: ExecVal -> Exec ExecVal
147tryForce (EThunk i) = force i
148tryForce tm = return tm
150debugThunks :: Exec ()
151debugThunks = do st <- getExecState
152 execIO $ putStrLn (take 4000 (show (exec_thunks st)))
154execute :: Term -> Idris Term
155execute tm = do est <- initState
156 ctxt <- getContext
157 res <- lift $ flip runExec est $ do res <- doExec [] ctxt tm
158 toTT res
159 case res of
160 Left err -> fail err
161 Right tm' -> return tm'
163ioWrap :: ExecVal -> ExecVal
164ioWrap tm = mkEApp (EP (DCon 0 2) (UN "prim__IO") EErased) [EErased, tm]
166ioUnit :: ExecVal
167ioUnit = ioWrap (EP Ref unitCon EErased)
169type ExecEnv = [(Name, ExecVal)]
171doExec :: ExecEnv -> Context -> Term -> Exec ExecVal
172doExec env ctxt p@(P Ref n ty) =
173 do let val = lookupDef n ctxt
174 case val of
175 [Function _ tm] -> doExec env ctxt tm
176 [TyDecl _ _] -> return (EP Ref n EErased) -- abstract def
177 [Operator tp arity op] -> return (EP Ref n EErased) -- will be special-cased later
178 [CaseOp _ _ _ _ _ [] (STerm tm) _ _] -> -- nullary fun
179 doExec env ctxt tm
180 [CaseOp _ _ _ _ _ ns sc _ _] -> return (EP Ref n EErased)
181 thing -> trace (take 200 $ "got to " ++ show thing ++ " lookup up " ++ show n) $ undefined
182doExec env ctxt p@(P Bound n ty) =
183 case lookup n env of
184 Nothing -> execFail "not found"
185 Just tm -> return tm
186doExec env ctxt (P (DCon a b) n _) = return (EP (DCon a b) n EErased)
187doExec env ctxt (P (TCon a b) n _) = return (EP (TCon a b) n EErased)
188doExec env ctxt v@(V i) | i < length env = return (snd (env !! i))
189 | otherwise = execFail "env too small"
190doExec env ctxt (Bind n (Let t v) body) = do v' <- doExec env ctxt v
191 doExec ((n, v'):env) ctxt body
192doExec env ctxt (Bind n (NLet t v) body) = trace "NLet" $ undefined
193doExec env ctxt tm@(Bind n b body) = return $
194 EBind n (fmap (\_->EErased) b)
195 (\arg -> doExec ((n, arg):env) ctxt body)
196doExec env ctxt a@(App _ _) = execApp env ctxt (unApply a)
197doExec env ctxt (Constant c) = return (EConstant c)
198doExec env ctxt (Proj tm i) = let (x, xs) = unApply tm in
199 doExec env ctxt ((x:xs) !! i)
200doExec env ctxt Erased = return EErased
201doExec env ctxt Impossible = fail "Tried to execute an impossible case"
202doExec env ctxt (TType u) = return (EType u)
204execApp :: ExecEnv -> Context -> (Term, [Term]) -> Exec ExecVal
205execApp env ctxt (f, args) = do newF <- doExec env ctxt f
206 laziness <- (++ repeat False) <$> (getLaziness newF)
207 newArgs <- mapM argExec (zip args laziness)
208 execApp' env ctxt newF newArgs
209 where getLaziness (EP _ (UN "lazy") _) = return [False, True]
210 getLaziness (EP _ n _) = do est <- getExecState
211 let argInfo = exec_implicits est
212 case lookupCtxtName n argInfo of
213 [] -> return (repeat False)
214 [ps] -> return $ map lazyarg (snd ps)
215 many -> execFail $ "Ambiguous " ++ show n ++ ", found " ++ (take 200 $ show many)
216 getLaziness _ = return (repeat False) -- ok due to zip above
217 argExec :: (Term, Bool) -> Exec ExecVal
218 argExec (tm, False) = doExec env ctxt tm
219 argExec (tm, True) = delay env ctxt tm
222execApp' :: ExecEnv -> Context -> ExecVal -> [ExecVal] -> Exec ExecVal
223execApp' env ctxt v [] = return v -- no args is just a constant! can result from function calls
224execApp' env ctxt (EP _ (UN "unsafePerformIO") _) (ty:action:rest) | (prim__IO, [_, v]) <- unApplyV action =
225 execApp' env ctxt v rest
227execApp' env ctxt (EP _ (UN "io_bind") _) args@(_:_:v:k:rest) | (prim__IO, [_, v']) <- unApplyV v =
228 do v'' <- tryForce v'
229 res <- execApp' env ctxt k [v''] >>= tryForce
230 execApp' env ctxt res rest
231execApp' env ctxt con@(EP _ (UN "io_return") _) args@(tp:v:rest) =
232 do v' <- tryForce v
233 execApp' env ctxt (mkEApp con [tp, v']) rest
235-- Special cases arising from not having access to the C RTS in the interpreter
236execApp' env ctxt (EP _ (UN "mkForeign") _) (_:fn:EConstant (Str arg):rest)
237 | Just (FFun "putStr" _ _) <- foreignFromTT fn = do execIO (putStr arg)
238 execApp' env ctxt ioUnit rest
239execApp' env ctxt (EP _ (UN "mkForeign") _) (_:fn:EConstant (Str f):EConstant (Str mode):rest)
240 | Just (FFun "fileOpen" _ _) <- foreignFromTT fn = do m <- case mode of
241 "r" -> return ReadMode
242 "w" -> return WriteMode
243 "a" -> return AppendMode
244 "rw" -> return ReadWriteMode
245 "wr" -> return ReadWriteMode
246 "r+" -> return ReadWriteMode
247 _ -> execFail ("Invalid mode for " ++ f ++ ": " ++ mode)
248 h <- execIO $ openFile f m
249 execApp' env ctxt (ioWrap (EHandle h)) rest
251execApp' env ctxt (EP _ (UN "mkForeign") _) (_:fn:(EHandle h):rest)
252 | Just (FFun "fileEOF" _ _) <- foreignFromTT fn = do eofp <- execIO $ hIsEOF h
253 let res = ioWrap (EConstant (I $ if eofp then 1 else 0))
254 execApp' env ctxt res rest
256execApp' env ctxt (EP _ (UN "mkForeign") _) (_:fn:(EHandle h):rest)
257 | Just (FFun "fileClose" _ _) <- foreignFromTT fn = do execIO $ hClose h
258 execApp' env ctxt ioUnit rest
261execApp' env ctxt f@(EP _ (UN "mkForeign") _) args@(ty:fn:xs) | Just (FFun _ argTs retT) <- foreignFromTT fn
262 , length xs >= length argTs =
263 do res <- stepForeign (ty:fn:take (length argTs) xs)
264 case res of
265 Nothing -> fail "Could not call foreign function"
266 Just r -> return (mkEApp r (drop (length argTs) xs))
267 | otherwise = return (mkEApp f args)
269execApp' env ctxt f@(EP _ n _) args =
270 do let val = lookupDef n ctxt
271 case val of
272 [Function _ tm] -> fail "should already have been eval'd"
273 [TyDecl nt ty] -> return $ mkEApp f args
274 [Operator tp arity op] ->
275 if length args >= arity
276 then do args' <- mapM tryForce $ take arity args
277 case getOp n args' of
278 Just res -> do r <- res
279 execApp' env ctxt r (drop arity args)
280 Nothing -> return (mkEApp f args)
281 else return (mkEApp f args)
282 [CaseOp _ _ _ _ _ [] (STerm tm) _ _] -> -- nullary fun
283 do rhs <- doExec env ctxt tm
284 execApp' env ctxt rhs args
285 [CaseOp _ _ _ _ _ ns sc _ _] ->
286 do res <- execCase env ctxt ns sc args
287 return $ fromMaybe (mkEApp f args) res
288 thing -> return $ mkEApp f args
289 where getOp :: Name -> [ExecVal] -> Maybe (Exec ExecVal)
290 getOp (UN "prim__addInt") [EConstant (I i1), EConstant (I i2)] =
291 primRes I (i1 + i2)
292 getOp (UN "prim__charToInt") [EConstant (Ch c)] =
293 primRes I (fromEnum c)
294 getOp (UN "prim__concat") [EConstant (Str s1), EConstant (Str s2)] =
295 primRes Str (s1 ++ s2)
296 getOp (UN "prim__eqChar") [EConstant (Ch c1), EConstant (Ch c2)] =
297 primResBool (c1 == c2)
298 getOp (UN "prim__eqInt") [EConstant (I i1), EConstant (I i2)] =
299 primResBool (i1 == i2)
300 getOp (UN "prim__eqString") [EConstant (Str s1), EConstant (Str s2)] =
301 primResBool (s1 == s2)
302 getOp (UN "prim__intToFloat") [EConstant (I i)] =
303 primRes Fl (fromRational (toRational i))
304 getOp (UN "prim__intToStr") [EConstant (I i)] =
305 primRes Str (show i)
306 getOp (UN "prim__ltInt") [EConstant (I i1), EConstant (I i2)] =
307 primResBool (i1 < i2)
308 getOp (UN "prim__mulBigInt") [EConstant (BI i1), EConstant (BI i2)] =
309 primRes BI (i1 * i2)
310 getOp (UN "prim__mulFloat") [EConstant (Fl i1), EConstant (Fl i2)] =
311 primRes Fl (i1 * i2)
312 getOp (UN "prim__mulInt") [EConstant (I i1), EConstant (I i2)] =
313 primRes I (i1 * i2)
314 getOp (UN "prim__readString") [EP _ (UN "prim__stdin") _] =
315 Just $ do line <- execIO getLine
316 return (EConstant (Str line))
317 getOp (UN "prim__readString") [EHandle h] =
318 Just $ do contents <- execIO $ hGetLine h
319 return (EConstant (Str contents))
320 getOp (UN "prim__strCons") [EConstant (Ch c), EConstant (Str s)] =
321 primRes Str (c:s)
322 getOp (UN "prim__strHead") [EConstant (Str (c:s))] =
323 primRes Ch c
324 getOp (UN "prim__strRev") [EConstant (Str s)] =
325 primRes Str (reverse s)
326 getOp (UN "prim__strTail") [EConstant (Str (c:s))] =
327 primRes Str s
328 getOp (UN "prim__subFloat") [EConstant (Fl i1), EConstant (Fl i2)] =
329 primRes Fl (i1 - i2)
330 getOp (UN "prim__subInt") [EConstant (I i1), EConstant (I i2)] =
331 primRes I (i1 - i2)
332 getOp n args = trace ("No prim " ++ show n ++ " for " ++ take 1000 (show args)) Nothing
334 primRes :: (a -> Const) -> a -> Maybe (Exec ExecVal)
335 primRes constr = Just . return . EConstant . constr
337 primResBool :: Bool -> Maybe (Exec ExecVal)
338 primResBool b = primRes I (if b then 1 else 0)
340execApp' env ctxt bnd@(EBind n b body) (arg:args) = do ret <- body arg
341 let (f', as) = unApplyV ret
342 execApp' env ctxt f' (as ++ args)
343execApp' env ctxt (EThunk i) args = do f <- force i
344 execApp' env ctxt f args
345execApp' env ctxt app@(EApp _ _) args2 | (f, args1) <- unApplyV app = execApp' env ctxt f (args1 ++ args2)
346execApp' env ctxt f args = return (mkEApp f args)
352-- | Overall wrapper for case tree execution. If there are enough arguments, it takes them,
353-- evaluates them, then begins the checks for matching cases.
354execCase :: ExecEnv -> Context -> [Name] -> SC -> [ExecVal] -> Exec (Maybe ExecVal)
355execCase env ctxt ns sc args =
356 let arity = length ns in
357 if arity <= length args
358 then do let amap = zip ns args
359 caseRes <- execCase' env ctxt amap sc
360 case caseRes of
361 Just res -> Just <$> execApp' (map (\(n, tm) -> (n, tm)) amap ++ env) ctxt res (drop arity args)
362 Nothing -> return Nothing
363 else return Nothing
365-- | Take bindings and a case tree and examines them, executing the matching case if possible.
366execCase' :: ExecEnv -> Context -> [(Name, ExecVal)] -> SC -> Exec (Maybe ExecVal)
367execCase' env ctxt amap (UnmatchedCase _) = return Nothing
368execCase' env ctxt amap (STerm tm) =
369 Just <$> doExec (map (\(n, v) -> (n, v)) amap ++ env) ctxt tm
370execCase' env ctxt amap (Case n alts) | Just tm <- lookup n amap =
371 do tm' <- tryForce tm
372 case chooseAlt tm' alts of
373 Just (newCase, newBindings) ->
374 let amap' = newBindings ++ (filter (\(x,_) -> not (elem x (map fst newBindings))) amap) in
375 execCase' env ctxt amap' newCase
376 Nothing -> return Nothing
378chooseAlt :: ExecVal -> [CaseAlt] -> Maybe (SC, [(Name, ExecVal)])
379chooseAlt _ (DefaultCase sc : alts) = Just (sc, [])
380chooseAlt (EConstant c) (ConstCase c' sc : alts) | c == c' = Just (sc, [])
381chooseAlt tm (ConCase n i ns sc : alts) | ((EP _ cn _), args) <- unApplyV tm
382 , cn == n = Just (sc, zip ns args)
383 | otherwise = chooseAlt tm alts
384chooseAlt tm (_:alts) = chooseAlt tm alts
385chooseAlt _ [] = Nothing
390idrisType :: FType -> ExecVal
391idrisType FUnit = EP Ref unitTy EErased
392idrisType ft = EConstant (idr ft)
393 where idr (FInt ty) = intTyToConst ty
394 idr FDouble = FlType
395 idr FChar = ChType
396 idr FString = StrType
397 idr FPtr = PtrType
399data Foreign = FFun String [FType] FType deriving Show
402call :: Foreign -> [ExecVal] -> Exec (Maybe ExecVal)
403call (FFun name argTypes retType) args =
404 do fn <- findForeign name
405 case fn of
406 Nothing -> return Nothing
407 Just f -> do res <- call' f args retType
408 return . Just . ioWrap $ res
409 where call' :: ForeignFun -> [ExecVal] -> FType -> Exec ExecVal
410 call' (Fun _ h) args (FInt ITNative) = do res <- execIO $ callFFI h retCInt (prepArgs args)
411 return (EConstant (I (fromIntegral res)))
412 call' (Fun _ h) args (FInt IT8) = do res <- execIO $ callFFI h retCChar (prepArgs args)
413 return (EConstant (B8 (fromIntegral res)))
414 call' (Fun _ h) args (FInt IT16) = do res <- execIO $ callFFI h retCWchar (prepArgs args)
415 return (EConstant (B16 (fromIntegral res)))
416 call' (Fun _ h) args (FInt IT32) = do res <- execIO $ callFFI h retCInt (prepArgs args)
417 return (EConstant (B32 (fromIntegral res)))
418 call' (Fun _ h) args (FInt IT64) = do res <- execIO $ callFFI h retCLong (prepArgs args)
419 return (EConstant (B64 (fromIntegral res)))
420 call' (Fun _ h) args FDouble = do res <- execIO $ callFFI h retCDouble (prepArgs args)
421 return (EConstant (Fl (realToFrac res)))
422 call' (Fun _ h) args FChar = do 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 "FInt") _) (EP _ (UN intTy) _)) =
461 case intTy of
462 "ITNative" -> Just $ FInt ITNative
463 "IT8" -> Just $ FInt IT8
464 "IT16" -> Just $ FInt IT16
465 "IT32" -> Just $ FInt IT32
466 "IT64" -> Just $ FInt IT64
467 _ -> Nothing
468getFTy (EP _ (UN t) _) =
469 case t of
470 "FFloat" -> Just FDouble
471 "FChar" -> Just FChar
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)