git.iko.soy/Idris-dev
on dd09721 help sign in
Idris-dev/src/Idris/Core/Execute.hs
547 lines 23 kB history raw
1{-# LANGUAGE PatternGuards, ExistentialQuantification, CPP #-}
2module Idris.Core.Execute (execute) where
4import Idris.AbsSyntax
5import Idris.AbsSyntaxTree
6import IRTS.Lang(FType(..))
8import Idris.Primitives(Prim(..), primitives)
10import Idris.Core.TT
11import Idris.Core.Evaluate
12import Idris.Core.CaseTree
14import Debug.Trace
16import Util.DynamicLinker
17import Util.System
19import Control.Applicative hiding (Const)
20import Control.Exception
21import Control.Monad.Trans
22import Control.Monad.Trans.State.Strict
23import Control.Monad.Trans.Error
24import Control.Monad
25import Data.Maybe
26import Data.Bits
27import qualified Data.Map as M
29#ifdef IDRIS_FFI
30import Foreign.LibFFI
31import Foreign.C.String
32import Foreign.Marshal.Alloc (free)
33import Foreign.Ptr
34#endif
36import System.IO
38#ifndef IDRIS_FFI
39execute :: Term -> Idris Term
40execute tm = fail "libffi not supported, rebuild Idris with -f FFI"
41#else
42-- else is rest of file
43readMay :: (Read a) => String -> Maybe a
44readMay s = case reads s of
45 [(x, "")] -> Just x
46 _ -> Nothing
48data Lazy = Delayed ExecEnv Context Term | Forced ExecVal deriving Show
50newtype ExecState = ExecState { exec_dynamic_libs :: [DynamicLib] -- ^ Dynamic libs from idris monad
51 }
53data ExecVal = EP NameType Name ExecVal
54 | EV Int
55 | EBind Name (Binder ExecVal) (ExecVal -> Exec ExecVal)
56 | EApp ExecVal ExecVal
57 | EType UExp
58 | EErased
59 | EConstant Const
60 | forall a. EPtr (Ptr a)
61 | EThunk Context ExecEnv Term
62 | EHandle Handle
64instance Show ExecVal where
65 show (EP _ n _) = show n
66 show (EV i) = "!!V" ++ show i ++ "!!"
67 show (EBind n b body) = "EBind " ++ show b ++ " <<fn>>"
68 show (EApp e1 e2) = show e1 ++ " (" ++ show e2 ++ ")"
69 show (EType _) = "Type"
70 show EErased = "[__]"
71 show (EConstant c) = show c
72 show (EPtr p) = "<<ptr " ++ show p ++ ">>"
73 show (EThunk _ env tm) = "<<thunk " ++ show env ++ "||||" ++ show tm ++ ">>"
74 show (EHandle h) = "<<handle " ++ show h ++ ">>"
76toTT :: ExecVal -> Exec Term
77toTT (EP nt n ty) = (P nt n) <$> (toTT ty)
78toTT (EV i) = return $ V i
79toTT (EBind n b body) = do body' <- body $ EP Bound n EErased
80 b' <- fixBinder b
81 Bind n b' <$> toTT body'
82 where fixBinder (Lam t) = Lam <$> toTT t
83 fixBinder (Pi t) = Pi <$> toTT t
84 fixBinder (Let t1 t2) = Let <$> toTT t1 <*> toTT t2
85 fixBinder (NLet t1 t2) = NLet <$> toTT t1 <*> toTT t2
86 fixBinder (Hole t) = Hole <$> toTT t
87 fixBinder (GHole i t) = GHole i <$> toTT t
88 fixBinder (Guess t1 t2) = Guess <$> toTT t1 <*> toTT t2
89 fixBinder (PVar t) = PVar <$> toTT t
90 fixBinder (PVTy t) = PVTy <$> toTT t
91toTT (EApp e1 e2) = do e1' <- toTT e1
92 e2' <- toTT e2
93 return $ App e1' e2'
94toTT (EType u) = return $ TType u
95toTT EErased = return Erased
96toTT (EConstant c) = return (Constant c)
97toTT (EThunk ctxt env tm) = do env' <- mapM toBinder env
98 return $ normalise ctxt env' tm
99 where toBinder (n, v) = do v' <- toTT v
100 return (n, Let Erased v')
101toTT (EHandle _) = return Erased
103unApplyV :: ExecVal -> (ExecVal, [ExecVal])
104unApplyV tm = ua [] tm
105 where ua args (EApp f a) = ua (a:args) f
106 ua args t = (t, args)
108mkEApp :: ExecVal -> [ExecVal] -> ExecVal
109mkEApp f [] = f
110mkEApp f (a:args) = mkEApp (EApp f a) args
112initState :: Idris ExecState
113initState = do ist <- getIState
114 return $ ExecState (idris_dynamic_libs ist)
116type Exec = ErrorT String (StateT ExecState IO)
118runExec :: Exec a -> ExecState -> IO (Either String a)
119runExec ex st = fst <$> runStateT (runErrorT ex) st
121getExecState :: Exec ExecState
122getExecState = lift get
124putExecState :: ExecState -> Exec ()
125putExecState = lift . put
127execFail :: String -> Exec a
128execFail = throwError
130execIO :: IO a -> Exec a
131execIO = lift . lift
134execute :: Term -> Idris Term
135execute tm = do est <- initState
136 ctxt <- getContext
137 res <- lift . lift . flip runExec est $
138 do res <- doExec [] ctxt tm
139 toTT res
140 case res of
141 Left err -> fail err
142 Right tm' -> return tm'
144ioWrap :: ExecVal -> ExecVal
145ioWrap tm = mkEApp (EP (DCon 0 2) (sUN "prim__IO") EErased) [EErased, tm]
147ioUnit :: ExecVal
148ioUnit = ioWrap (EP Ref unitCon EErased)
150type ExecEnv = [(Name, ExecVal)]
152doExec :: ExecEnv -> Context -> Term -> Exec ExecVal
153doExec env ctxt p@(P Ref n ty) | Just v <- lookup n env = return v
154doExec env ctxt p@(P Ref n ty) =
155 do let val = lookupDef n ctxt
156 case val of
157 [Function _ tm] -> doExec env ctxt tm
158 [TyDecl _ _] -> return (EP Ref n EErased) -- abstract def
159 [Operator tp arity op] -> return (EP Ref n EErased) -- will be special-cased later
160 [CaseOp _ _ _ _ _ (CaseDefs _ ([], STerm tm) _ _)] -> -- nullary fun
161 doExec env ctxt tm
162 [CaseOp _ _ _ _ _ (CaseDefs _ (ns, sc) _ _)] -> return (EP Ref n EErased)
163 [] -> execFail $ "Could not find " ++ show n ++ " in definitions."
164 thing -> trace (take 200 $ "got to " ++ show thing ++ " lookup up " ++ show n) $ undefined
165doExec env ctxt p@(P Bound n ty) =
166 case lookup n env of
167 Nothing -> execFail "not found"
168 Just tm -> return tm
169doExec env ctxt (P (DCon a b) n _) = return (EP (DCon a b) n EErased)
170doExec env ctxt (P (TCon a b) n _) = return (EP (TCon a b) n EErased)
171doExec env ctxt v@(V i) | i < length env = return (snd (env !! i))
172 | otherwise = execFail "env too small"
173doExec env ctxt (Bind n (Let t v) body) = do v' <- doExec env ctxt v
174 doExec ((n, v'):env) ctxt body
175doExec env ctxt (Bind n (NLet t v) body) = trace "NLet" $ undefined
176doExec env ctxt tm@(Bind n b body) = return $
177 EBind n (fmap (\_->EErased) b)
178 (\arg -> doExec ((n, arg):env) ctxt body)
179doExec env ctxt a@(App _ _) =
180 do let (f, args) = unApply a
181 f' <- doExec env ctxt f
182 args' <- case f' of
183 (EP _ d _) | d == delay ->
184 case args of
185 [t,a,tm] -> do t' <- doExec env ctxt t
186 a' <- doExec env ctxt a
187 return [t', a', EThunk ctxt env tm]
188 _ -> mapM (doExec env ctxt) args -- partial applications are fine to evaluate
189 fun' -> do mapM (doExec env ctxt) args
190 execApp env ctxt f' args'
191doExec env ctxt (Constant c) = return (EConstant c)
192doExec env ctxt (Proj tm i) = let (x, xs) = unApply tm in
193 doExec env ctxt ((x:xs) !! i)
194doExec env ctxt Erased = return EErased
195doExec env ctxt Impossible = fail "Tried to execute an impossible case"
196doExec env ctxt (TType u) = return (EType u)
198execApp :: ExecEnv -> Context -> ExecVal -> [ExecVal] -> Exec ExecVal
199execApp env ctxt v [] = return v -- no args is just a constant! can result from function calls
200execApp env ctxt (EP _ f _) (t:a:delayed:rest)
201 | f == force
202 , (_, [_, _, EThunk tmCtxt tmEnv tm]) <- unApplyV delayed =
203 do tm' <- doExec tmEnv tmCtxt tm
204 execApp env ctxt tm' rest
205execApp env ctxt (EP _ fp _) (ty:action:rest)
206 | fp == upio,
207 (prim__IO, [_, v]) <- unApplyV action
208 = execApp env ctxt v rest
210execApp env ctxt (EP _ fp _) args@(_:_:v:k:rest)
211 | fp == piobind,
212 (prim__IO, [_, v']) <- unApplyV v =
213 do res <- execApp env ctxt k [v']
214 execApp env ctxt res rest
215execApp env ctxt con@(EP _ fp _) args@(tp:v:rest)
216 | fp == pioret = execApp env ctxt (mkEApp con [tp, v]) rest
218-- Special cases arising from not having access to the C RTS in the interpreter
219execApp env ctxt (EP _ fp _) (_:fn:EConstant (Str arg):_:rest)
220 | fp == mkfprim,
221 Just (FFun "putStr" _ _) <- foreignFromTT fn
222 = do execIO (putStr arg)
223 execApp env ctxt ioUnit rest
224execApp env ctxt (EP _ fp _) (_:fn:_:EHandle h:_:rest)
225 | fp == mkfprim,
226 Just (FFun "idris_readStr" _ _) <- foreignFromTT fn
227 = do contents <- execIO $ hGetLine h
228 execApp env ctxt (EConstant (Str (contents ++ "\n"))) rest
229execApp env ctxt (EP _ fp _) (_:fn:EConstant (Str f):EConstant (Str mode):rest)
230 | fp == mkfprim,
231 Just (FFun "fileOpen" _ _) <- foreignFromTT fn
232 = do f <- execIO $
233 catch (do let m = case mode of
234 "r" -> Right ReadMode
235 "w" -> Right WriteMode
236 "a" -> Right AppendMode
237 "rw" -> Right ReadWriteMode
238 "wr" -> Right ReadWriteMode
239 "r+" -> Right ReadWriteMode
240 _ -> Left ("Invalid mode for " ++ f ++ ": " ++ mode)
241 case fmap (openFile f) m of
242 Right h -> do h' <- h; return $ Right (ioWrap (EHandle h'), tail rest)
243 Left err -> return $ Left err)
244 (\e -> let _ = ( e::SomeException)
245 in return $ Right (ioWrap (EPtr nullPtr), tail rest))
246 case f of
247 Left err -> execFail err
248 Right (res, rest) -> execApp env ctxt res rest
250execApp env ctxt (EP _ fp _) (_:fn:(EHandle h):rest)
251 | fp == mkfprim,
252 Just (FFun "fileEOF" _ _) <- foreignFromTT fn
253 = do eofp <- execIO $ hIsEOF h
254 let res = ioWrap (EConstant (I $ if eofp then 1 else 0))
255 execApp env ctxt res (tail rest)
257execApp env ctxt (EP _ fp _) (_:fn:(EHandle h):rest)
258 | fp == mkfprim,
259 Just (FFun "fileClose" _ _) <- foreignFromTT fn
260 = do execIO $ hClose h
261 execApp env ctxt ioUnit (tail rest)
263execApp env ctxt (EP _ fp _) (_:fn:(EPtr p):rest)
264 | fp == mkfprim,
265 Just (FFun "isNull" _ _) <- foreignFromTT fn
266 = let res = ioWrap . EConstant . I $
267 if p == nullPtr then 1 else 0
268 in execApp env ctxt res (tail rest)
270-- Handles will be checked as null pointers sometimes - but if we got a
271-- real Handle, then it's valid, so just return 1.
272execApp env ctxt (EP _ fp _) (_:fn:(EHandle h):rest)
273 | fp == mkfprim,
274 Just (FFun "isNull" _ _) <- foreignFromTT fn
275 = let res = ioWrap . EConstant . I $ 0
276 in execApp env ctxt res (tail rest)
278-- A foreign-returned char* has to be tested for NULL sometimes
279execApp env ctxt (EP _ fp _) (_:fn:EConstant (Str s):rest)
280 | fp == mkfprim,
281 Just (FFun "isNull" _ _) <- foreignFromTT fn
282 = let res = ioWrap . EConstant . I $ 0
283 in execApp env ctxt res (tail rest)
285-- Right now, there's no way to send command-line arguments to the executor,
286-- so just return 0.
287execApp env ctxt (EP _ fp _) (_:fn:rest)
288 | fp == mkfprim,
289 Just (FFun "idris_numArgs" _ _) <- foreignFromTT fn
290 = let res = ioWrap . EConstant . I $ 0
291 in execApp env ctxt res (tail rest)
292-- Throw away the 'World' argument to the foreign function
294execApp env ctxt f@(EP _ fp _) args@(ty:fn:xs) | fp == mkfprim
295 = case foreignFromTT fn of
296 Just (FFun f argTs retT) | length xs >= length argTs ->
297 do let (args', xs') = (take (length argTs) xs, -- foreign args
298 drop (length argTs + 1) xs) -- rest
299 res <- stepForeign (ty:fn:args')
300 case res of
301 Nothing -> fail $ "Could not call foreign function \"" ++ f ++
302 "\" with args " ++ show args
303 Just r -> return (mkEApp r xs')
304 Nothing -> return (mkEApp f args)
306execApp env ctxt c@(EP (DCon _ arity) n _) args =
307 do let args' = take arity args
308 let restArgs = drop arity args
309 execApp env ctxt (mkEApp c args') restArgs
311execApp env ctxt c@(EP (TCon _ arity) n _) args =
312 do let args' = take arity args
313 let restArgs = drop arity args
314 execApp env ctxt (mkEApp c args') restArgs
316execApp env ctxt f@(EP _ n _) args =
317 do let val = lookupDef n ctxt
318 case val of
319 [Function _ tm] -> fail "should already have been eval'd"
320 [TyDecl nt ty] -> return $ mkEApp f args
321 [Operator tp arity op] ->
322 if length args >= arity
323 then let args' = take arity args in
324 case getOp n args' of
325 Just res -> do r <- res
326 execApp env ctxt r (drop arity args)
327 Nothing -> return (mkEApp f args)
328 else return (mkEApp f args)
329 [CaseOp _ _ _ _ _ (CaseDefs _ ([], STerm tm) _ _)] -> -- nullary fun
330 do rhs <- doExec env ctxt tm
331 execApp env ctxt rhs args
332 [CaseOp _ _ _ _ _ (CaseDefs _ (ns, sc) _ _)] ->
333 do res <- execCase env ctxt ns sc args
334 return $ fromMaybe (mkEApp f args) res
335 thing -> return $ mkEApp f args
336execApp env ctxt bnd@(EBind n b body) (arg:args) = do ret <- body arg
337 let (f', as) = unApplyV ret
338 execApp env ctxt f' (as ++ args)
339execApp env ctxt app@(EApp _ _) args2 | (f, args1) <- unApplyV app = execApp env ctxt f (args1 ++ args2)
340execApp env ctxt f args = return (mkEApp f args)
342prs = sUN "prim__readString"
343pbm = sUN "prim__believe_me"
344pstd = sUN "prim__stdin"
345mkfprim = sUN "mkForeignPrim"
346pioret = sUN "prim_io_return"
347piobind = sUN "prim_io_bind"
348upio = sUN "unsafePerformPrimIO"
349delay = sUN "Delay"
350force = sUN "Force"
352-- | Look up primitive operations in the global table and transform them into ExecVal functions
353getOp :: Name -> [ExecVal] -> Maybe (Exec ExecVal)
354getOp fn [_, _, x] | fn == pbm = Just (return x)
355getOp fn [EP _ fn' _]
356 | fn == prs && fn' == pstd =
357 Just $ do line <- execIO getLine
358 return (EConstant (Str line))
359getOp fn [EHandle h]
360 | fn == prs =
361 Just $ do contents <- execIO $ hGetLine h
362 return (EConstant (Str (contents ++ "\n")))
363getOp n args = getPrim n primitives >>= flip applyPrim args
364 where getPrim :: Name -> [Prim] -> Maybe ([ExecVal] -> Maybe ExecVal)
365 getPrim n [] = Nothing
366 getPrim n ((Prim pn _ arity def _ _) : prims) | n == pn = Just $ execPrim def
367 | otherwise = getPrim n prims
369 execPrim :: ([Const] -> Maybe Const) -> [ExecVal] -> Maybe ExecVal
370 execPrim f args = EConstant <$> (mapM getConst args >>= f)
372 getConst (EConstant c) = Just c
373 getConst _ = Nothing
375 applyPrim :: ([ExecVal] -> Maybe ExecVal) -> [ExecVal] -> Maybe (Exec ExecVal)
376 applyPrim fn args = return <$> fn args
381-- | Overall wrapper for case tree execution. If there are enough arguments, it takes them,
382-- evaluates them, then begins the checks for matching cases.
383execCase :: ExecEnv -> Context -> [Name] -> SC -> [ExecVal] -> Exec (Maybe ExecVal)
384execCase env ctxt ns sc args =
385 let arity = length ns in
386 if arity <= length args
387 then do let amap = zip ns args
388-- trace ("Case " ++ show sc ++ "\n in " ++ show amap ++"\n in env " ++ show env ++ "\n\n" ) $ return ()
389 caseRes <- execCase' env ctxt amap sc
390 case caseRes of
391 Just res -> Just <$> execApp (map (\(n, tm) -> (n, tm)) amap ++ env) ctxt res (drop arity args)
392 Nothing -> return Nothing
393 else return Nothing
395-- | Take bindings and a case tree and examines them, executing the matching case if possible.
396execCase' :: ExecEnv -> Context -> [(Name, ExecVal)] -> SC -> Exec (Maybe ExecVal)
397execCase' env ctxt amap (UnmatchedCase _) = return Nothing
398execCase' env ctxt amap (STerm tm) =
399 Just <$> doExec (map (\(n, v) -> (n, v)) amap ++ env) ctxt tm
400execCase' env ctxt amap (Case n alts) | Just tm <- lookup n amap =
401 case chooseAlt tm alts of
402 Just (newCase, newBindings) ->
403 let amap' = newBindings ++ (filter (\(x,_) -> not (elem x (map fst newBindings))) amap) in
404 execCase' env ctxt amap' newCase
405 Nothing -> return Nothing
407chooseAlt :: ExecVal -> [CaseAlt] -> Maybe (SC, [(Name, ExecVal)])
408chooseAlt _ (DefaultCase sc : alts) = Just (sc, [])
409chooseAlt (EConstant c) (ConstCase c' sc : alts) | c == c' = Just (sc, [])
410chooseAlt tm (ConCase n i ns sc : alts) | ((EP _ cn _), args) <- unApplyV tm
411 , cn == n = Just (sc, zip ns args)
412 | otherwise = chooseAlt tm alts
413chooseAlt tm (_:alts) = chooseAlt tm alts
414chooseAlt _ [] = Nothing
419idrisType :: FType -> ExecVal
420idrisType FUnit = EP Ref unitTy EErased
421idrisType ft = EConstant (idr ft)
422 where idr (FArith ty) = AType ty
423 idr FString = StrType
424 idr FPtr = PtrType
426data Foreign = FFun String [FType] FType deriving Show
429call :: Foreign -> [ExecVal] -> Exec (Maybe ExecVal)
430call (FFun name argTypes retType) args =
431 do fn <- findForeign name
432 maybe (return Nothing) (\f -> Just . ioWrap <$> call' f args retType) fn
433 where call' :: ForeignFun -> [ExecVal] -> FType -> Exec ExecVal
434 call' (Fun _ h) args (FArith (ATInt ITNative)) = do
435 res <- execIO $ callFFI h retCInt (prepArgs args)
436 return (EConstant (I (fromIntegral res)))
437 call' (Fun _ h) args (FArith (ATInt (ITFixed IT8))) = do
438 res <- execIO $ callFFI h retCChar (prepArgs args)
439 return (EConstant (B8 (fromIntegral res)))
440 call' (Fun _ h) args (FArith (ATInt (ITFixed IT16))) = do
441 res <- execIO $ callFFI h retCWchar (prepArgs args)
442 return (EConstant (B16 (fromIntegral res)))
443 call' (Fun _ h) args (FArith (ATInt (ITFixed IT32))) = do
444 res <- execIO $ callFFI h retCInt (prepArgs args)
445 return (EConstant (B32 (fromIntegral res)))
446 call' (Fun _ h) args (FArith (ATInt (ITFixed IT64))) = do
447 res <- execIO $ callFFI h retCLong (prepArgs args)
448 return (EConstant (B64 (fromIntegral res)))
449 call' (Fun _ h) args (FArith ATFloat) = do
450 res <- execIO $ callFFI h retCDouble (prepArgs args)
451 return (EConstant (Fl (realToFrac res)))
452 call' (Fun _ h) args (FArith (ATInt ITChar)) = do
453 res <- execIO $ callFFI h retCChar (prepArgs args)
454 return (EConstant (Ch (castCCharToChar res)))
455 call' (Fun _ h) args FString = do res <- execIO $ callFFI h retCString (prepArgs args)
456 if res == nullPtr
457 then return (EPtr res)
458 else do hStr <- execIO $ peekCString res
459 return (EConstant (Str hStr))
461 call' (Fun _ h) args FPtr = EPtr <$> (execIO $ callFFI h (retPtr retVoid) (prepArgs args))
462 call' (Fun _ h) args FUnit = do _ <- execIO $ callFFI h retVoid (prepArgs args)
463 return $ EP Ref unitCon EErased
464-- call' (Fun _ h) args other = fail ("Unsupported foreign return type " ++ show other)
467 prepArgs = map prepArg
468 prepArg (EConstant (I i)) = argCInt (fromIntegral i)
469 prepArg (EConstant (B8 i)) = argCChar (fromIntegral i)
470 prepArg (EConstant (B16 i)) = argCWchar (fromIntegral i)
471 prepArg (EConstant (B32 i)) = argCInt (fromIntegral i)
472 prepArg (EConstant (B64 i)) = argCLong (fromIntegral i)
473 prepArg (EConstant (Fl f)) = argCDouble (realToFrac f)
474 prepArg (EConstant (Ch c)) = argCChar (castCharToCChar c) -- FIXME - castCharToCChar only safe for first 256 chars
475 prepArg (EConstant (Str s)) = argString s
476 prepArg (EPtr p) = argPtr p
477 prepArg other = trace ("Could not use " ++ take 100 (show other) ++ " as FFI arg.") undefined
481foreignFromTT :: ExecVal -> Maybe Foreign
482foreignFromTT t = case (unApplyV t) of
483 (_, [(EConstant (Str name)), args, ret]) ->
484 do argTy <- unEList args
485 argFTy <- sequence $ map getFTy argTy
486 retFTy <- getFTy ret
487 return $ FFun name argFTy retFTy
488 _ -> trace ("failed to construct ffun") Nothing
490getFTy :: ExecVal -> Maybe FType
491getFTy (EApp (EP _ (UN fi) _) (EP _ (UN intTy) _))
492 | fi == txt "FIntT" =
493 case str intTy of
494 "ITNative" -> Just (FArith (ATInt ITNative))
495 "ITChar" -> Just (FArith (ATInt ITChar))
496 "IT8" -> Just (FArith (ATInt (ITFixed IT8)))
497 "IT16" -> Just (FArith (ATInt (ITFixed IT16)))
498 "IT32" -> Just (FArith (ATInt (ITFixed IT32)))
499 "IT64" -> Just (FArith (ATInt (ITFixed IT64)))
500 _ -> Nothing
501getFTy (EP _ (UN t) _) =
502 case str t of
503 "FFloat" -> Just (FArith ATFloat)
504 "FString" -> Just FString
505 "FPtr" -> Just FPtr
506 "FUnit" -> Just FUnit
507 _ -> Nothing
508getFTy _ = Nothing
510unEList :: ExecVal -> Maybe [ExecVal]
511unEList tm = case unApplyV tm of
512 (nil, [_]) -> Just []
513 (cons, ([_, x, xs])) ->
514 do rest <- unEList xs
515 return $ x:rest
516 (f, args) -> Nothing
519toConst :: Term -> Maybe Const
520toConst (Constant c) = Just c
521toConst _ = Nothing
523stepForeign :: [ExecVal] -> Exec (Maybe ExecVal)
524stepForeign (ty:fn:args) = let ffun = foreignFromTT fn
525 in case (call <$> ffun) of
526 Just f -> f args
527 Nothing -> return Nothing
528stepForeign _ = fail "Tried to call foreign function that wasn't mkForeignPrim"
530mapMaybeM :: (Functor m, Monad m) => (a -> m (Maybe b)) -> [a] -> m [b]
531mapMaybeM f [] = return []
532mapMaybeM f (x:xs) = do rest <- mapMaybeM f xs
533 maybe rest (:rest) <$> f x
534findForeign :: String -> Exec (Maybe ForeignFun)
535findForeign fn = do est <- getExecState
536 let libs = exec_dynamic_libs est
537 fns <- mapMaybeM getFn libs
538 case fns of
539 [f] -> return (Just f)
540 [] -> do execIO . putStrLn $ "Symbol \"" ++ fn ++ "\" not found"
541 return Nothing
542 fs -> do execIO . putStrLn $ "Symbol \"" ++ fn ++ "\" is ambiguous. Found " ++
543 show (length fs) ++ " occurrences."
544 return Nothing
545 where getFn lib = execIO $ catchIO (tryLoadFn fn lib) (\_ -> return Nothing)
547#endif