Typing.hs

{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-|
Module      : HsLua.Typing
Copyright   : © 2023-2024 Albert Krewinkel
License     : MIT
Maintainer  : Albert Krewinkel <tarleb@hslua.org>

The module provides Haskell types and values that can be used to
describe and declare the types of Lua values.
-}
module HsLua.Typing
  ( TypeSpec (..)
  , TypeDocs (..)
  , (#|#)
  , typeSpecToString
  , typeSpecFromString
    -- * Types
  , anyType
  , voidType
    -- ** Built-in types
  , booleanType
  , functionType
  , integerType
  , lightUserdataType
  , nilType
  , numberType
  , stringType
  , tableType
  , threadType
  , userdataType
    -- ** Type constructors
  , recType
  , seqType
    -- * Marshalling
  , pushTypeSpec
  , peekTypeSpec
  , pushTypeDoc
  , peekTypeDoc
  ) where

import Control.Monad (when)
import Data.Char (toLower, toUpper)
import Data.List (find, intercalate)
import Data.String (IsString (..))
import Data.Text (Text)
import GHC.Generics (Generic)
import HsLua.Core
import HsLua.Core.Utf8 (toString)
import HsLua.Marshalling
import Text.Read (readMaybe)
import Text.ParserCombinators.ReadP hiding (choice)
import qualified HsLua.Core as HsLua
import qualified Data.Map as Map

-- | Type specification for Lua values.
data TypeSpec =
    BasicType HsLua.Type              -- ^ Built-in type
  | NamedType Name                    -- ^ A type that's been given a name.
  | SeqType TypeSpec                  -- ^ Sequence of the given type.
  | SumType [TypeSpec]                -- ^ Union type; a sum type.
  | RecType (Map.Map Name TypeSpec)   -- ^ Record type (type product).
  | FunType [TypeSpec] [TypeSpec]     -- ^ Function type.
  | AnyType                           -- ^ Unconstrained type.
  deriving (Eq, Generic, Ord, Show)

-- | Documented custom type.
data TypeDocs = TypeDocs
  { typeDescription :: Text
  , typeSpec        :: TypeSpec
  , typeRegistry    :: Maybe Name
  }
  deriving (Eq, Generic, Ord, Show)

-- | Returns the sum of two type specifiers, declaring that a Lua value
-- can have either type.
(#|#) :: TypeSpec -> TypeSpec -> TypeSpec
AnyType    #|# _          = AnyType
_          #|# AnyType    = AnyType
SumType [] #|# b          = b                   -- `SumType []` is `Void`
a          #|# SumType [] = a
SumType a  #|# SumType b  = SumType (a ++ b)
SumType a  #|# b          = SumType (a ++ [b])
a          #|# SumType b  = SumType (a : b)
a          #|# b          =
  if a == b
  then a
  else SumType [a, b]

-- | Generate a string representation of the type specifier.
typeSpecToString :: TypeSpec -> String
typeSpecToString = \case
  BasicType t   -> basicTypeName t
  NamedType nt  -> toString $ fromName nt
  AnyType       -> "any"
  FunType{}     -> "function"
  RecType{}     -> "table"
  SeqType t     -> '{' : typeSpecToString t ++ ",...}"
  SumType specs -> intercalate "|" (map typeSpecToString specs)

-- | Creates a 'TypeSpec' value from a string.
--
-- The implementation currently handles basic types, sequences, and
-- alternatives. A string that cannot be parsed is returned as a 'Named'
-- type with the full string as the name.
typeSpecFromString :: String -> TypeSpec
typeSpecFromString = \case
  "any"            -> anyType
  "boolean"        -> booleanType
  "function"       -> functionType
  "integer"        -> integerType
  "light userdata" -> lightUserdataType
  "nil"            -> nilType
  "number"         -> numberType
  "string"         -> stringType
  "table"          -> tableType
  "userdata"       -> userdataType
  s                -> case find completeParse (readP_to_S pTypeSpec s) of
                        Nothing -> NamedType (fromString s)  -- Parsing failed
                        Just (x,_) -> x
 where completeParse = null . snd

pTypeSpec :: ReadP TypeSpec
pTypeSpec = foldr (#|#) voidType <$> sepBy (pAtomic <++ pSeq) (char '|')

-- | Parses an atomic, non-composite type.
pAtomic :: ReadP TypeSpec
pAtomic = do
  str <- many1 (satisfy (`notElem` ['{', '}', '|', ',']))
  pure $ case str of
    "any"            -> anyType
    "boolean"        -> booleanType
    "function"       -> functionType
    "integer"        -> integerType
    "light userdata" -> lightUserdataType
    "nil"            -> nilType
    "number"         -> numberType
    "string"         -> stringType
    "table"          -> tableType
    "userdata"       -> userdataType
    _                -> NamedType (fromString str)

-- | Parses a sequence type.
pSeq :: ReadP TypeSpec
pSeq = seqType <$> (char '{' *> pTypeSpec <* pComma <* pEllipsis <* char '}')
  where
    pComma :: ReadP Char
    pComma = skipSpaces *> char ',' <* skipSpaces

    pEllipsis :: ReadP String
    pEllipsis = string "..." <* skipSpaces

--
-- Built-in types
--

-- | Unconstraint type; any Lua value.
anyType :: TypeSpec
anyType = AnyType

-- | A type for which there cannot be any value.
voidType :: TypeSpec
voidType = SumType []

-- | The built-in @boolean@ Lua type.
booleanType :: TypeSpec
booleanType = BasicType HsLua.TypeBoolean

-- | The built-in @function@ Lua type.
functionType :: TypeSpec
functionType = BasicType HsLua.TypeFunction

-- | The built-in @light userdata@ Lua type.
lightUserdataType :: TypeSpec
lightUserdataType = BasicType HsLua.TypeLightUserdata

-- | The built-in @nil@ Lua type.
nilType :: TypeSpec
nilType = BasicType HsLua.TypeNil

-- | The built-in @number@ Lua type.
numberType :: TypeSpec
numberType = BasicType HsLua.TypeNumber

-- | The built-in @string@ Lua type.
stringType :: TypeSpec
stringType = BasicType HsLua.TypeString

-- | The built-in @table@ Lua type.
tableType :: TypeSpec
tableType = BasicType HsLua.TypeTable

-- | The built-in @thread@ Lua type.
threadType :: TypeSpec
threadType = BasicType HsLua.TypeThread

-- | The built-in @userdata@ Lua type.
userdataType :: TypeSpec
userdataType = BasicType HsLua.TypeUserdata

-- | A Lua integer type.
integerType :: TypeSpec
integerType = NamedType "integer"

-- | For backwards compatibility and convenience, strings can be used as
-- TypeSpec values.
instance IsString TypeSpec where
  fromString = typeSpecFromString

--
-- Constructors
--

-- | Creates a sequence type.
seqType :: TypeSpec -> TypeSpec
seqType = SeqType

-- | Creates a record type.
recType :: [(Name, TypeSpec)] -> TypeSpec
recType = RecType . Map.fromList

--
-- Marshalling
--

-- | Pushes documentation for a custom type.
pushTypeDoc :: LuaError e => Pusher e TypeDocs
pushTypeDoc td = do
  checkstack' 8 "HsLua.Typing.pushTypeDoc"
  pushAsTable
    [ ("description", pushText . typeDescription)
    , ("typespec", pushTypeSpec . typeSpec)
    , ("registry", maybe pushnil pushName . typeRegistry)
    ] td

-- | Retrieves a custom type specifier.
peekTypeDoc :: LuaError e => Peeker e TypeDocs
peekTypeDoc = typeChecked "TypeDoc" istable $ \idx -> do
  liftLua $ checkstack' 8 "HsLua.Typing.peekTypeDoc"
  desc <- peekFieldRaw peekText "description" idx
  spec <- peekFieldRaw peekTypeSpec "typespec" idx
  regn <- peekFieldRaw (peekNilOr peekName) "registry" idx
  return $ TypeDocs desc spec regn

-- | Pushes a table representation of a 'TypeSpec' to the stack.
pushTypeSpec :: LuaError e
             => TypeSpec
             -> LuaE e ()
pushTypeSpec ts = do
  checkstack' 8 "HsLua.Typing.pushTypeSpec"
  case ts of
    BasicType bt  -> pushAsTable [("basic", pushString . basicTypeName)] bt
    NamedType n   -> pushAsTable [("named", pushName)] n
    SeqType seq'  -> pushAsTable [("sequence", pushTypeSpec)] seq'
    SumType st    -> pushAsTable [("sum", pushList pushTypeSpec)] st
    RecType rt    -> pushAsTable [("record", pushMap pushName pushTypeSpec)] rt
    FunType dt ct -> pushAsTable [("domain", pushList pushTypeSpec . fst)
                                 ,("codomain", pushList pushTypeSpec . snd)]
                                 (dt, ct)
    AnyType       -> pushAsTable [("any", pushBool)] True
  created <- newmetatable "HsLua.TypeSpec"
  when created $ do
    pushHaskellFunction $ do
      ts' <- forcePeek $ peekTypeSpec (nth 1)
      pushString $ typeSpecToString ts'
      return 1
    setfield (nth 2) "__tostring"
  setmetatable (nth 2)

-- | String representation of a basic type. This is similar to, but
-- different from the output of @'typename'@, in that 'TypeNone' is
-- reported as @none@ (instead of @no value@) and 'TypeLightUserdata' is
-- represented as @light userdata@ (instead of @userdata@).
basicTypeName :: Type -> String
basicTypeName = \case
  TypeLightUserdata -> "light userdata"
  t                 -> map toLower . drop 4 $ show t

-- | Retrieves a 'TypeSpec' from a table on the stack.
peekTypeSpec :: LuaError e => Peeker e TypeSpec
peekTypeSpec = typeChecked "TypeSpec" istable $ \idx -> do
  liftLua $ checkstack' 8 "HsLua.Typing.peekTypeSpec"
  choice
    [ fmap BasicType . peekFieldRaw peekBasicType "basic"
    , fmap NamedType . peekFieldRaw peekName "named"
    , fmap SeqType . peekFieldRaw peekTypeSpec "sequence"
    , fmap SumType . peekFieldRaw (peekList peekTypeSpec) "sum"
    , fmap RecType . peekFieldRaw (peekMap peekName peekTypeSpec) "record"
    , \i -> do
        dom <- peekFieldRaw (peekList peekTypeSpec) "domain" i
        cod <- peekFieldRaw (peekList peekTypeSpec) "codomain" i
        pure $ FunType dom cod
    , const (pure AnyType)
    ] idx
 where
  peekBasicType idx = peekString idx >>= \case
    "light userdata" -> pure TypeLightUserdata
    (c:cs)           -> maybe (fail "unknown type") pure $
                        readMaybe ("Type" ++ toUpper c : cs)
    _                -> failPeek "invalid type string"