|
| 1 | +{-# LANGUAGE ScopedTypeVariables #-} |
| 2 | +{-| |
| 3 | +Module : Foreign.Lua.Module.System |
| 4 | +Copyright : © 2019 Albert Krewinkel |
| 5 | +License : MIT |
| 6 | +Maintainer : Albert Krewinkel <albert+hslua@zeitkraut.de> |
| 7 | +Stability : alpha |
| 8 | +Portability : Requires language extensions ForeignFunctionInterface, |
| 9 | + OverloadedStrings. |
| 10 | +
|
| 11 | +Provide a Lua module containing a selection of @'System'@ functions. |
| 12 | +-} |
| 13 | +module Foreign.Lua.Module.System |
| 14 | + ( pushModule |
| 15 | + , preloadModule |
| 16 | + ) |
| 17 | +where |
| 18 | + |
| 19 | +import Control.Applicative ((<$>)) |
| 20 | +import Control.Exception (IOException, catch, evaluate, try) |
| 21 | +import Data.Maybe (fromMaybe) |
| 22 | +import Foreign.Lua (Lua, NumResults(..), Optional (..), Peekable, Pushable, |
| 23 | + StackIndex, ToHaskellFunction) |
| 24 | +import System.IO.Error (IOError, isDoesNotExistError) |
| 25 | + |
| 26 | +import qualified Foreign.Lua as Lua |
| 27 | +import qualified System.Directory as Directory |
| 28 | +import qualified System.IO.Temp as Temp |
| 29 | + |
| 30 | +-- | Pushes the @text@ module to the lua stack. |
| 31 | +pushModule :: Lua NumResults |
| 32 | +pushModule = do |
| 33 | + Lua.newtable |
| 34 | + addFunction "chdir" chdir |
| 35 | + addFunction "currentdir" currentdir |
| 36 | + addFunction "ls" ls |
| 37 | + addFunction "pwd" currentdir |
| 38 | + addFunction "tmpdirname" tmpdirname |
| 39 | + addFunction "with_tmpdir" with_tmpdir |
| 40 | + return 1 |
| 41 | + |
| 42 | +-- | Add the text module under the given name to the table of preloaded |
| 43 | +-- packages. |
| 44 | +preloadModule :: String -> Lua () |
| 45 | +preloadModule = flip addPackagePreloader pushModule |
| 46 | + |
| 47 | +-- | Registers a preloading function. Takes an module name and the Lua |
| 48 | +-- operation which produces the package. |
| 49 | +addPackagePreloader :: String -> Lua NumResults -> Lua () |
| 50 | +addPackagePreloader name modulePusher = do |
| 51 | + Lua.getfield Lua.registryindex Lua.preloadTableRegistryField |
| 52 | + Lua.pushHaskellFunction modulePusher |
| 53 | + Lua.setfield (-2) name |
| 54 | + Lua.pop 1 |
| 55 | + |
| 56 | +-- | Attach a function to the table at the top of the stack, using the |
| 57 | +-- given name. |
| 58 | +addFunction :: ToHaskellFunction a => String -> a -> Lua () |
| 59 | +addFunction name fn = do |
| 60 | + Lua.push name |
| 61 | + Lua.pushHaskellFunction fn |
| 62 | + Lua.rawset (-3) |
| 63 | + |
| 64 | +-- | Lua callback function |
| 65 | +newtype Callback = Callback { callbackStackIndex :: StackIndex } |
| 66 | + |
| 67 | +instance Peekable Callback where |
| 68 | + peek idx = do |
| 69 | + isFn <- Lua.isfunction idx |
| 70 | + if isFn |
| 71 | + then return (Callback idx) |
| 72 | + else Lua.throwException "Function expected" |
| 73 | + |
| 74 | +instance Pushable Callback where |
| 75 | + push (Callback idx) = Lua.pushvalue idx |
| 76 | + |
| 77 | + |
| 78 | +-- | Any value of unknown type |
| 79 | +newtype AnyValue = AnyValue { fromAnyValue :: StackIndex } |
| 80 | + |
| 81 | +instance Peekable AnyValue where |
| 82 | + peek = return . AnyValue |
| 83 | + |
| 84 | +instance Pushable AnyValue where |
| 85 | + push (AnyValue idx) = Lua.pushvalue idx |
| 86 | + |
| 87 | +with_tmpdir :: String -- ^ parent dir or template |
| 88 | + -> AnyValue -- ^ template or callback |
| 89 | + -> Optional Callback -- ^ callback or nil |
| 90 | + -> Lua NumResults |
| 91 | +with_tmpdir parentDir tmpl callback = do |
| 92 | + case fromOptional callback of |
| 93 | + Nothing -> do |
| 94 | + -- At most two args. The first arg (parent dir) has probably been |
| 95 | + -- omitted, so we shift arguments and use the system's canonical |
| 96 | + -- temporary directory. |
| 97 | + let tmpl' = parentDir |
| 98 | + callback' <- Lua.peek (fromAnyValue tmpl) |
| 99 | + Temp.withSystemTempDirectory tmpl' (callWithFilename callback') |
| 100 | + Just callback' -> do |
| 101 | + -- all args given. Second value must be converted to a string. |
| 102 | + tmpl' <- Lua.peek (fromAnyValue tmpl) |
| 103 | + Temp.withTempDirectory parentDir tmpl' (callWithFilename callback') |
| 104 | + |
| 105 | +-- | Call Lua callback function with the given filename as its argument. |
| 106 | +callWithFilename :: Callback -> FilePath -> Lua NumResults |
| 107 | +callWithFilename callback filename = do |
| 108 | + oldTop <- Lua.gettop |
| 109 | + Lua.push callback |
| 110 | + Lua.push filename |
| 111 | + Lua.call (Lua.NumArgs 1) Lua.multret |
| 112 | + newTop <- Lua.gettop |
| 113 | + return . NumResults . fromIntegral . Lua.fromStackIndex $ |
| 114 | + newTop - oldTop |
| 115 | + |
| 116 | +tmpdirname :: Lua FilePath |
| 117 | +tmpdirname = do |
| 118 | + eitherTmpdir <- Lua.liftIO $ try Directory.getTemporaryDirectory |
| 119 | + case eitherTmpdir :: Either IOException FilePath of |
| 120 | + Right tmpdir -> return tmpdir |
| 121 | + Left _ -> Lua.throwException ("The operating system has no notion " ++ |
| 122 | + "of temporary directory.") |
| 123 | + |
| 124 | +-- | List the contents of a directory. |
| 125 | +ls :: Optional FilePath -> Lua [FilePath] |
| 126 | +ls fp = do |
| 127 | + let fp' = fromMaybe "." (fromOptional fp) |
| 128 | + ioToLua (Directory.listDirectory fp') |
| 129 | + |
| 130 | +-- | Return the current working directory. |
| 131 | +currentdir :: Lua FilePath |
| 132 | +currentdir = ioToLua Directory.getCurrentDirectory |
| 133 | + |
| 134 | +-- | Change current working directory. |
| 135 | +chdir :: FilePath -> Lua () |
| 136 | +chdir fp = ioToLua $ Directory.setCurrentDirectory fp |
| 137 | + |
| 138 | +-- | Convert a System IO operation to a Lua operation. |
| 139 | +ioToLua :: IO a -> Lua a |
| 140 | +ioToLua action = do |
| 141 | + result <- Lua.liftIO (try action) |
| 142 | + case result of |
| 143 | + Right result' -> return result' |
| 144 | + Left err -> Lua.throwException (show (err :: IOException)) |
0 commit comments