packages feed

hslua-module-system (empty) → 0.1.0

raw patch · 6 files changed

+291/−0 lines, 6 filesdep +basedep +directorydep +hsluasetup-changed

Dependencies added: base, directory, hslua, hslua-module-system, tasty, tasty-hunit, temporary, text

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for hslua-module-system++## 0.1.0 -- 2019-04-26++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2019 Albert Krewinkel++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hslua-module-system.cabal view
@@ -0,0 +1,49 @@+name:                hslua-module-system+version:             0.1.0+synopsis:            Lua module wrapper around Haskell's System module.++description:         Provides access to system information and functionality+                     to Lua scripts via Haskell's `System` module.+                     .+                     Intended usage for this package is to preload it by adding+                     the loader function to `package.preload`. Note that the+                     Lua `package` library must have already been loaded before+                     the loader can be added.+homepage:            https://github.com/hslua/hslua-module-system+license:             MIT+license-file:        LICENSE+author:              Albert Krewinkel+maintainer:          albert+hslua@zeitkraut.de+copyright:           Albert Krewinkel <albert+hslua@zeitkraut.de>+category:            Foreign+build-type:          Simple+extra-source-files:  CHANGELOG.md+cabal-version:       >=1.10++source-repository head+  type:              git+  location:          https://github.com/hslua/hslua-module-system.git++library+  build-depends:       base       >= 4.9    && < 5+                     , directory >= 1.3     && < 1.4+                     , hslua      >= 1.0    && < 1.2+                     , temporary  >= 1.2    && < 1.4+  default-extensions:  LambdaCase+  default-language:    Haskell2010+  exposed-modules:     Foreign.Lua.Module.System+  hs-source-dirs:      src+  other-extensions:    OverloadedStrings++test-suite test-hslua-module-system+  default-language:    Haskell2010+  type:                exitcode-stdio-1.0+  main-is:             test-hslua-module-system.hs+  hs-source-dirs:      test+  ghc-options:         -Wall -threaded+  build-depends:       base+                     , hslua+                     , hslua-module-system+                     , tasty+                     , tasty-hunit+                     , text
+ src/Foreign/Lua/Module/System.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-|+Module      : Foreign.Lua.Module.System+Copyright   : © 2019 Albert Krewinkel+License     : MIT+Maintainer  : Albert Krewinkel <albert+hslua@zeitkraut.de>+Stability   : alpha+Portability : Requires language extensions ForeignFunctionInterface,+              OverloadedStrings.++Provide a Lua module containing a selection of @'System'@ functions.+-}+module Foreign.Lua.Module.System+  ( pushModule+  , preloadModule+  )+where++import Control.Applicative ((<$>))+import Control.Exception (IOException, catch, evaluate, try)+import Data.Maybe (fromMaybe)+import Foreign.Lua (Lua, NumResults(..), Optional (..), Peekable, Pushable,+                    StackIndex, ToHaskellFunction)+import System.IO.Error (IOError, isDoesNotExistError)++import qualified Foreign.Lua as Lua+import qualified System.Directory as Directory+import qualified System.Environment as Env+import qualified System.IO.Temp as Temp++-- | Pushes the @text@ module to the lua stack.+pushModule :: Lua NumResults+pushModule = do+  Lua.newtable+  addFunction "chdir" chdir+  addFunction "currentdir" currentdir+  addFunction "env" env+  addFunction "getenv" getenv+  addFunction "ls" ls+  addFunction "pwd" currentdir+  addFunction "setenv" setenv+  addFunction "tmpdirname" tmpdirname+  addFunction "with_tmpdir" with_tmpdir+  return 1++-- | Add the text module under the given name to the table of preloaded+-- packages.+preloadModule :: String -> Lua ()+preloadModule = flip addPackagePreloader pushModule++-- | Registers a preloading function. Takes an module name and the Lua+-- operation which produces the package.+addPackagePreloader :: String -> Lua NumResults -> Lua ()+addPackagePreloader name modulePusher = do+  Lua.getfield Lua.registryindex Lua.preloadTableRegistryField+  Lua.pushHaskellFunction modulePusher+  Lua.setfield (-2) name+  Lua.pop 1++-- | Attach a function to the table at the top of the stack, using the+-- given name.+addFunction :: ToHaskellFunction a => String -> a -> Lua ()+addFunction name fn = do+  Lua.push name+  Lua.pushHaskellFunction fn+  Lua.rawset (-3)++-- | Lua callback function+newtype Callback = Callback { callbackStackIndex :: StackIndex }++instance Peekable Callback where+  peek idx = do+    isFn <- Lua.isfunction idx+    if isFn+      then return (Callback idx)+      else Lua.throwException "Function expected"++instance Pushable Callback where+  push (Callback idx) = Lua.pushvalue idx+++-- | Any value of unknown type+newtype AnyValue = AnyValue { fromAnyValue :: StackIndex }++instance Peekable AnyValue where+  peek = return . AnyValue++instance Pushable AnyValue where+  push (AnyValue idx) = Lua.pushvalue idx++with_tmpdir :: String            -- ^ parent dir or template+            -> AnyValue          -- ^ template or callback+            -> Optional Callback -- ^ callback or nil+            -> Lua NumResults+with_tmpdir parentDir tmpl callback = do+  case fromOptional callback of+    Nothing -> do+      -- At most two args. The first arg (parent dir) has probably been+      -- omitted, so we shift arguments and use the system's canonical+      -- temporary directory.+      let tmpl' = parentDir+      callback' <- Lua.peek (fromAnyValue tmpl)+      Temp.withSystemTempDirectory tmpl' (callWithFilename callback')+    Just callback' -> do+      -- all args given. Second value must be converted to a string.+      tmpl' <- Lua.peek (fromAnyValue tmpl)+      Temp.withTempDirectory parentDir tmpl' (callWithFilename callback')++-- | Call Lua callback function with the given filename as its argument.+callWithFilename :: Callback -> FilePath -> Lua NumResults+callWithFilename callback filename = do+  oldTop <- Lua.gettop+  Lua.push callback+  Lua.push filename+  Lua.call (Lua.NumArgs 1) Lua.multret+  newTop <- Lua.gettop+  return . NumResults . fromIntegral . Lua.fromStackIndex $+    newTop - oldTop++-- | List the contents of a directory.+ls :: Optional FilePath -> Lua [FilePath]+ls fp = do+  let fp' = fromMaybe "." (fromOptional fp)+  ioToLua (Directory.listDirectory fp')++-- | Change current working directory.+chdir :: FilePath -> Lua ()+chdir fp = ioToLua $ Directory.setCurrentDirectory fp++-- | Return the current working directory.+currentdir :: Lua FilePath+currentdir = ioToLua Directory.getCurrentDirectory++-- | Retrieve the entire environment+env :: Lua NumResults+env = do+  kvs <- ioToLua Env.getEnvironment+  let addValue (k, v) = Lua.push k *> Lua.push v *> Lua.rawset (-3)+  Lua.newtable+  mapM_ addValue kvs+  return (NumResults 1)++-- | Returns the value of an environment variable+getenv :: String -> Lua (Optional String)+getenv name = ioToLua (Optional <$> Env.lookupEnv name)++-- | Set the specified environment variable to a new value.+setenv :: String -> String -> Lua ()+setenv name value = ioToLua (Env.setEnv name value)++-- | Get the current directory for temporary files.+tmpdirname :: Lua FilePath+tmpdirname = ioToLua Directory.getTemporaryDirectory++-- | Convert a System IO operation to a Lua operation.+ioToLua :: IO a -> Lua a+ioToLua action = do+  result <- Lua.liftIO (try action)+  case result of+    Right result' -> return result'+    Left err      -> Lua.throwException (show (err :: IOException))
+ test/test-hslua-module-system.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE OverloadedStrings #-}+{-|+Module      : Main+Copyright   : © 2019 Albert Krewinkel+License     : MIT+Maintainer  : Albert Krewinkel <albert+hslua@zeitkraut.de>+Stability   : alpha+Portability : Requires language extensions ForeignFunctionInterface,+              OverloadedStrings.++Tests for the `system` Lua module.+-}++import Control.Monad (void, when)+import Foreign.Lua (Lua)+import Foreign.Lua.Module.System (preloadModule, pushModule)+import Test.Tasty (TestTree, defaultMain, testGroup)+import Test.Tasty.HUnit (assertEqual, testCase)++import qualified Foreign.Lua as Lua++main :: IO ()+main = defaultMain $ testGroup "hslua-module-system" [tests]++-- | HSpec tests for the Lua 'system' module+tests :: TestTree+tests = testGroup "HsLua System module"+  [ testCase "system module can be pushed to the stack" $+      Lua.run (void pushModule)++  , testCase "text module can be added to the preloader" . Lua.run $ do+      Lua.openlibs+      preloadModule "system"+      assertEqual' "function not added to preloader" Lua.TypeFunction =<< do+        Lua.getglobal' "package.preload.system"+        Lua.ltype (-1)++  , testCase "text module can be loaded as hstext" . Lua.run $ do+      Lua.openlibs+      preloadModule "system"+      assertEqual' "loading the module fails " Lua.OK =<<+        Lua.dostring "require 'system'"++  , testCase "Lua tests pass" . Lua.run $ do+      Lua.openlibs+      preloadModule "system"+      assertEqual' "error while running lua tests" Lua.OK =<< do+        st <- Lua.loadfile "test/system-module-tests.lua"+        when (st == Lua.OK) $ Lua.call 0 0+        return st+  ]++assertEqual' :: (Show a, Eq a) => String -> a -> a -> Lua ()+assertEqual' msg expected = Lua.liftIO . assertEqual msg expected