git.iko.soy/Idris-dev
on master help sign in
Handle idris_mkFileError through a special-case.
4317228Chris Ford
src/Idris/Core/Execute.hs+29−2
compare with master
unifiedsplit
@@ -36,6 +36,8 @@ import Data.Time.Clock.POSIX (getPOSIXTime)
36import Data.Traversable (forM)
36import Data.Traversable (forM)
37import Debug.Trace
37import Debug.Trace
38import System.IO
38import System.IO
39+import System.IO.Error
40+import System.IO.Unsafe
39
41
40#ifdef IDRIS_FFI
42#ifdef IDRIS_FFI
41import Foreign.C.String
43import Foreign.C.String
@@ -73,6 +75,27 @@ data ExecVal = EP NameType Name ExecVal
73 | EHandle Handle
75 | EHandle Handle
74 | EStringBuf (IORef String)
76 | EStringBuf (IORef String)
75
77
78+fileError :: IORef ExecVal
79+{-# NOINLINE fileError #-}
80+fileError = unsafePerformIO $ newIORef $ operationNotPermitted
81+
82+operationNotPermitted =
83+ ioWrap $ mkRaw $ EApp (EP (DCon 0 1 False)
84+ (sNS (sUN "GenericFileError") ["File", "Prelude"])
85+ EErased)
86+ (EConstant (I 1))
87+
88+namedFileError name =
89+ ioWrap $ mkRaw $ (EP (DCon 0 0 False)
90+ (sNS (sUN name) ["File", "Prelude"])
91+ EErased)
92+
93+mapError :: IOError -> ExecVal
94+mapError e
95+ | (isDoesNotExistError e) = namedFileError "FileNotFound"
96+ | (isPermissionError e) = namedFileError "PermissionDenied"
97+ | otherwise = operationNotPermitted
98+
76mkRaw :: ExecVal -> ExecVal
99mkRaw :: ExecVal -> ExecVal
77mkRaw arg = EApp (EApp (EP (DCon 0 1 False) (sNS (sUN "MkRaw") ["FFI_C"]) EErased)
100mkRaw arg = EApp (EApp (EP (DCon 0 1 False) (sNS (sUN "MkRaw") ["FFI_C"]) EErased)
78 EErased) arg
101 EErased) arg
@@ -326,6 +349,10 @@ execForeign env ctxt arity ty fn xs onfail
326 execApp env ctxt ch xs
349 execApp env ctxt ch xs
327 | Just (FFun "idris_time" _ _) <- foreignFromTT arity ty fn xs
350 | Just (FFun "idris_time" _ _) <- foreignFromTT arity ty fn xs
328 = do execIO $ fmap (ioWrap . EConstant . I . round) getPOSIXTime
351 = do execIO $ fmap (ioWrap . EConstant . I . round) getPOSIXTime
352+ | Just (FFun "idris_showerror" _ _) <- foreignFromTT arity ty fn xs
353+ = do execIO $ return $ ioWrap $ EConstant $ Str "Operation not permitted"
354+ | Just (FFun "idris_mkFileError" _ _) <- foreignFromTT arity ty fn xs
355+ = do execIO $ readIORef fileError
329 | Just (FFun "fileOpen" [(_,fileStr), (_,modeStr)] _) <- foreignFromTT arity ty fn xs
356 | Just (FFun "fileOpen" [(_,fileStr), (_,modeStr)] _) <- foreignFromTT arity ty fn xs
330 = case (fileStr, modeStr) of
357 = case (fileStr, modeStr) of
331 (EConstant (Str f), EConstant (Str mode)) ->
358 (EConstant (Str f), EConstant (Str mode)) ->
@@ -343,8 +370,8 @@ execForeign env ctxt arity ty fn xs onfail
343 hSetBinaryMode h' True
370 hSetBinaryMode h' True
344 return $ Right (ioWrap (EHandle h'), drop arity xs)
371 return $ Right (ioWrap (EHandle h'), drop arity xs)
345 Left err -> return $ Left err)
372 Left err -> return $ Left err)
346− (\e -> let _ = ( e::SomeException)
373+ (\e -> do writeIORef fileError $ mapError e
347− in return $ Right (ioWrap (EPtr nullPtr), drop arity xs))
374+ return $ Right (ioWrap (EPtr nullPtr), drop arity xs))
348 case f of
375 case f of
349 Left err -> execFail . Msg $ err
376 Left err -> execFail . Msg $ err
350 Right (res, rest) -> execApp env ctxt res rest
377 Right (res, rest) -> execApp env ctxt res rest