Generic Lua Table Parsing Example

GenericLuaParsing.hs

#!/usr/bin/env stack 
-- stack --resolver lts-3.4 --install-ghc runghc --package hslua --package bytestring --package monad-loops --package shakespeare --package heredoc --package interpolatedstring-perl6

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE BangPatterns #-}

import qualified Scripting.Lua as Lua

import           Control.Applicative
import           Control.Monad (forM)
import           Control.Monad.Loops

import           Data.List
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map

import           Text.Hamlet (shamlet)
import           Text.Heredoc (here)
import           Text.InterpolatedString.Perl6 (qq)
import           Text.Blaze.Html.Renderer.String (renderHtml)

config = [here|

function person(name, email)
  return {
    ["name"]  = name
  , ["email"] = email
  }
end

interestedParties = {
    person("aaa",     "[email protected]")
  , person("bbb",     "[email protected]")
  , person("ccc",     "[email protected]")
  , person("ddd",     "[email protected]")
}

foo = {
  ["1"] = "bar", ["2"] = "est", ["3"] = "me", ["4"] = "dee", ["5"] = "see"
}

|]

-------------

data LuaValue = LuaString String
              | LuaNumber Double
              | LuaBoolean Bool
              | LuaTable (Map LuaValue LuaValue)
              | LuaNil
              deriving (Show, Eq, Ord)

instance Lua.StackValue LuaValue where
  push l (LuaString  value) = Lua.push l (BC.pack value)
  push l (LuaNumber  value) = Lua.push l value
  push l (LuaBoolean value) = Lua.push l value
  push l (LuaNil          ) = Lua.push l ()
  push l (LuaTable       _) = fail "Cannot pass a table on the stack (not implemented)."

  peek l i = do
    number <- underlyingNumber
    string <- underlyingString
    bool   <- underlyingBool
    nil    <- underlyingNil
    table  <- underlyingTable
    -- Ordering is important here because numbers are coerced to strings.
    -- Also this means that string numbers are coerced to doubles.
    -- TODO: fix. this is clearly broken JavaScript-style behaviour.
    return $ number <|> string <|> bool <|> nil <|> table
    where underlyingString :: IO (Maybe LuaValue)
          underlyingString = (fmap (LuaString . BC.unpack)) <$> (Lua.peek l i)
          underlyingNumber :: IO (Maybe LuaValue)
          underlyingNumber = do
            isNumber <- Lua.isnumber l 1
            -- The underlying implementation will coerce strings to numbers.
            -- This stops that from happening by exiting early if it is not a number.
            if isNumber then ((fmap LuaNumber) <$> (Lua.peek l i)) else (return Nothing)
          underlyingBool   :: IO (Maybe LuaValue)
          underlyingBool   = (fmap LuaBoolean) <$> (Lua.peek l i)
          underlyingNil'   :: IO (Maybe ())
          underlyingNil'   = Lua.peek l i
          underlyingNil    :: IO (Maybe LuaValue)
          underlyingNil    = (fmap (\_ -> LuaNil)) <$> underlyingNil'
          underlyingTable  = do
            isTable <- Lua.istable l i
            if isTable then (Just <$> underlyingTable') else return Nothing
          underlyingTable'  :: IO LuaValue
          underlyingTable'  = do
              !values <- traverse
              !table <- return $ (LuaTable . Map.fromList) values
              return table
            where 

              traverse :: IO [ (LuaValue, LuaValue) ]
              traverse = do
                -- Push the table to the top of the stack.
                Lua.pushvalue l i
                -- Pop nil on to signal to start iterating at the start of the table.
                -- (it uses the top of the stack to determine where it is up to)
                Lua.pushnil l
                -- Stack: Nil -> Table -> ... (original)
                -- Once we've popped an element on to the stack the table position in the stack 
                -- will have increased by 1 accordingly.
                let hasNext = Lua.next l (-2)
                !pairs <- whileM' hasNext getNext
                -- Pop the table off of the stack (return it to the way it was).
                Lua.pop l 1
                return pairs
              getNext :: IO (LuaValue, LuaValue)
              getNext = do
                  -- Copy the key on to the top of the stack
                  Lua.pushvalue l (-2)
                  -- Stack: Key -> Value -> Key -> Table -> ... (original)
                  !(key :: Maybe LuaValue)   <- Lua.peek l (-1)
                  !(value :: Maybe LuaValue) <- Lua.peek l (-2)
                  -- Popping key + value from stack (leaving the previous key on top)
                  Lua.pop l 2
                  -- Stack: Key -> Table -> ... (original)
                  !key'   <- maybe (fail "Key was not parseable") return key
                  !value' <- maybe (fail "Value was not parseable") return value
                  return $ (key', value')
  

-------------

main = do
  l <- Lua.newstate
  Lua.openlibs l -- (probably not needed since we don't want standard libraries).
  -- Load the Lua script and evalute it (so the globals table gets set).
  Lua.loadstring l config ""
  Lua.call l 0 0
  --
  g <- Lua.getglobal l "interestedParties"
  (r :: Maybe LuaValue) <- Lua.peek l 1
  putStrLn $ show r
  Lua.close l