{-# LANGUAGE OverloadedStrings #-}
{-|
Module      : Foreign.Lua.Module
Copyright   : © 2019-2020 Albert Krewinkel
License     : MIT
Maintainer  : Albert Krewinkel <albert+hslua@zeitkraut.de>
Stability   : alpha
Portability : Requires GHC 8 or later.

Utility functions for HsLua modules.
-}
module Foreign.Lua.Module
  ( requirehs
  , preloadhs
  , addfield
  , addfunction
  , create
    -- * Module
  , Module (..)
  , Field (..)
  , registerModule
  , preloadModule
  , pushModule
    -- * Documentation
  , render
  )
where

import Control.Monad (unless, forM_)
import Data.Text (Text)
import Foreign.Lua.Call (HaskellFunction)
import Foreign.Lua.Core
import Foreign.Lua.Push (pushText)
import Foreign.Lua.Types (Pushable, push)
import Foreign.Lua.FunctionCalling
  ( ToHaskellFunction
  , pushHaskellFunction
  )
import qualified Data.Text as T
import qualified Foreign.Lua.Call as Call

-- | Load a module, defined by a Haskell action, under the given
-- name.
--
-- Similar to @luaL_required@: After checking "loaded" table,
-- calls @pushMod@ to push a module to the stack, and registers
-- the result in @package.loaded@ table.
--
-- The @pushMod@ function must push exactly one element to the top
-- of the stack. This is not checked, but failure to do so will
-- lead to problems. Lua's @package@ module must have been loaded
-- by the time this function is invoked.
--
-- Leaves a copy of the module on the stack.
requirehs :: String -> Lua () -> Lua ()
requirehs :: String -> Lua () -> Lua ()
requirehs String
modname Lua ()
pushMod = do
  -- get table of loaded modules
  StackIndex -> String -> Lua ()
getfield StackIndex
registryindex String
loadedTableRegistryField

  -- Check whether module has already been loaded.
  StackIndex -> String -> Lua ()
getfield StackIndex
stackTop String
modname  -- LOADED[modname]
  Bool
alreadyLoaded <- StackIndex -> Lua Bool
toboolean StackIndex
stackTop

  Bool -> Lua () -> Lua ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
alreadyLoaded (Lua () -> Lua ()) -> Lua () -> Lua ()
forall a b. (a -> b) -> a -> b
$ do
    StackIndex -> Lua ()
pop StackIndex
1  -- remove field
    Lua ()
pushMod  -- push module
    StackIndex -> Lua ()
pushvalue StackIndex
stackTop  -- make copy of module
    -- add module under the given name (LOADED[modname] = module)
    StackIndex -> String -> Lua ()
setfield (CInt -> StackIndex
nthFromTop CInt
3) String
modname

  StackIndex -> Lua ()
remove (CInt -> StackIndex
nthFromTop CInt
2)  -- remove table of loaded modules

-- | Registers a preloading function. Takes an module name and the
-- Lua operation which produces the package.
preloadhs :: String -> Lua NumResults -> Lua ()
preloadhs :: String -> Lua NumResults -> Lua ()
preloadhs String
name Lua NumResults
pushMod = do
  StackIndex -> String -> Lua ()
getfield StackIndex
registryindex String
preloadTableRegistryField
  Lua NumResults -> Lua ()
forall a. ToHaskellFunction a => a -> Lua ()
pushHaskellFunction Lua NumResults
pushMod
  StackIndex -> String -> Lua ()
setfield (CInt -> StackIndex
nthFromTop CInt
2) String
name
  StackIndex -> Lua ()
pop StackIndex
1

-- | Add a string-indexed field to the table at the top of the
-- stack.
addfield :: Pushable a => String -> a -> Lua ()
addfield :: String -> a -> Lua ()
addfield String
name a
value = do
  String -> Lua ()
forall a. Pushable a => a -> Lua ()
push String
name
  a -> Lua ()
forall a. Pushable a => a -> Lua ()
push a
value
  StackIndex -> Lua ()
rawset (CInt -> StackIndex
nthFromTop CInt
3)

-- | Attach a function to the table at the top of the stack, using
-- the given name.
addfunction :: ToHaskellFunction a => String -> a -> Lua ()
addfunction :: String -> a -> Lua ()
addfunction String
name a
fn = do
  String -> Lua ()
forall a. Pushable a => a -> Lua ()
push String
name
  a -> Lua ()
forall a. ToHaskellFunction a => a -> Lua ()
pushHaskellFunction a
fn
  StackIndex -> Lua ()
rawset (CInt -> StackIndex
nthFromTop CInt
3)

-- | Create a new module (i.e., a Lua table).
create :: Lua ()
create :: Lua ()
create = Lua ()
newtable

-- | Named and documented Lua module.
data Module = Module
  { Module -> Text
moduleName :: Text
  , Module -> Text
moduleDescription :: Text
  , Module -> [Field]
moduleFields :: [Field]
  , Module -> [(Text, HaskellFunction)]
moduleFunctions :: [(Text, HaskellFunction)]
  }

-- | Self-documenting module field
data Field = Field
  { Field -> Text
fieldName :: Text
  , Field -> Text
fieldDescription :: Text
  , Field -> Lua ()
fieldPushValue :: Lua ()
  }


-- | Registers a 'Module'; leaves a copy of the module table on
-- the stack.
registerModule :: Module -> Lua ()
registerModule :: Module -> Lua ()
registerModule Module
mdl =
  String -> Lua () -> Lua ()
requirehs (Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Module -> Text
moduleName Module
mdl) (Module -> Lua ()
pushModule Module
mdl)

-- | Preload self-documenting module.
preloadModule :: Module -> Lua ()
preloadModule :: Module -> Lua ()
preloadModule Module
mdl =
  String -> Lua NumResults -> Lua ()
preloadhs (Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Module -> Text
moduleName Module
mdl) (Lua NumResults -> Lua ()) -> Lua NumResults -> Lua ()
forall a b. (a -> b) -> a -> b
$ do
    Module -> Lua ()
pushModule Module
mdl
    NumResults -> Lua NumResults
forall (m :: * -> *) a. Monad m => a -> m a
return (CInt -> NumResults
NumResults CInt
1)

pushModule :: Module -> Lua ()
pushModule :: Module -> Lua ()
pushModule Module
mdl = do
  Lua ()
create
  [(Text, HaskellFunction)]
-> ((Text, HaskellFunction) -> Lua ()) -> Lua ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Module -> [(Text, HaskellFunction)]
moduleFunctions Module
mdl) (((Text, HaskellFunction) -> Lua ()) -> Lua ())
-> ((Text, HaskellFunction) -> Lua ()) -> Lua ()
forall a b. (a -> b) -> a -> b
$ \(Text
name, HaskellFunction
fn) -> do
    Pusher Text
pushText Text
name
    HaskellFunction -> Lua ()
Call.pushHaskellFunction HaskellFunction
fn
    StackIndex -> Lua ()
rawset (CInt -> StackIndex
nthFromTop CInt
3)

-- | Renders module documentation as Markdown.
render :: Module -> Text
render :: Module -> Text
render Module
mdl =
  let fields :: [Field]
fields = Module -> [Field]
moduleFields Module
mdl
  in [Text] -> Text
T.unlines
     [ Text
"# " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Module -> Text
moduleName Module
mdl
     , Text
""
     , Module -> Text
moduleDescription Module
mdl
     , if [Field] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Module -> [Field]
moduleFields Module
mdl) then Text
"" else [Field] -> Text
renderFields [Field]
fields
     , Text
"## Functions"
     , Text
""
     ]
     Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"\n"
        (((Text, HaskellFunction) -> Text)
-> [(Text, HaskellFunction)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> HaskellFunction -> Text)
-> (Text, HaskellFunction) -> Text
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> HaskellFunction -> Text
renderFunctionDoc) (Module -> [(Text, HaskellFunction)]
moduleFunctions Module
mdl))

-- | Renders documentation of a function.
renderFunctionDoc :: Text             -- ^ name
                  -> HaskellFunction  -- ^ function
                  -> Text             -- ^ function docs
renderFunctionDoc :: Text -> HaskellFunction -> Text
renderFunctionDoc Text
name HaskellFunction
fn =
  case HaskellFunction -> Maybe FunctionDoc
Call.functionDoc HaskellFunction
fn of
    Maybe FunctionDoc
Nothing -> Text
""
    Just FunctionDoc
fnDoc -> Text -> [Text] -> Text
T.intercalate Text
"\n"
      [ Text
"### " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FunctionDoc -> Text
renderFunctionParams FunctionDoc
fnDoc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
      , Text
""
      , FunctionDoc -> Text
Call.render FunctionDoc
fnDoc
      ]

renderFunctionParams :: Call.FunctionDoc -> Text
renderFunctionParams :: FunctionDoc -> Text
renderFunctionParams FunctionDoc
fd =
    Text -> [Text] -> Text
T.intercalate Text
", "
  ([Text] -> Text)
-> ([ParameterDoc] -> [Text]) -> [ParameterDoc] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ParameterDoc -> Text) -> [ParameterDoc] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ParameterDoc -> Text
Call.parameterName
  ([ParameterDoc] -> Text) -> [ParameterDoc] -> Text
forall a b. (a -> b) -> a -> b
$ FunctionDoc -> [ParameterDoc]
Call.parameterDocs FunctionDoc
fd

-- | Render documentation for fields as Markdown.
renderFields :: [Field] -> Text
renderFields :: [Field] -> Text
renderFields [Field]
fs =
  if [Field] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Field]
fs
  then Text
forall a. Monoid a => a
mempty
  else [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Field -> Text) -> [Field] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Field -> Text
renderField [Field]
fs

-- | Renders documentation for a single field.
renderField :: Field -> Text
renderField :: Field -> Text
renderField Field
f =
  Text
"### " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Field -> Text
fieldName Field
f Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Field -> Text
fieldDescription Field
f Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"