{-# 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 (TypeSpec -> TypeSpec -> Bool
(TypeSpec -> TypeSpec -> Bool)
-> (TypeSpec -> TypeSpec -> Bool) -> Eq TypeSpec
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TypeSpec -> TypeSpec -> Bool
== :: TypeSpec -> TypeSpec -> Bool
$c/= :: TypeSpec -> TypeSpec -> Bool
/= :: TypeSpec -> TypeSpec -> Bool
Eq, (forall x. TypeSpec -> Rep TypeSpec x)
-> (forall x. Rep TypeSpec x -> TypeSpec) -> Generic TypeSpec
forall x. Rep TypeSpec x -> TypeSpec
forall x. TypeSpec -> Rep TypeSpec x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TypeSpec -> Rep TypeSpec x
from :: forall x. TypeSpec -> Rep TypeSpec x
$cto :: forall x. Rep TypeSpec x -> TypeSpec
to :: forall x. Rep TypeSpec x -> TypeSpec
Generic, Eq TypeSpec
Eq TypeSpec =>
(TypeSpec -> TypeSpec -> Ordering)
-> (TypeSpec -> TypeSpec -> Bool)
-> (TypeSpec -> TypeSpec -> Bool)
-> (TypeSpec -> TypeSpec -> Bool)
-> (TypeSpec -> TypeSpec -> Bool)
-> (TypeSpec -> TypeSpec -> TypeSpec)
-> (TypeSpec -> TypeSpec -> TypeSpec)
-> Ord TypeSpec
TypeSpec -> TypeSpec -> Bool
TypeSpec -> TypeSpec -> Ordering
TypeSpec -> TypeSpec -> TypeSpec
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: TypeSpec -> TypeSpec -> Ordering
compare :: TypeSpec -> TypeSpec -> Ordering
$c< :: TypeSpec -> TypeSpec -> Bool
< :: TypeSpec -> TypeSpec -> Bool
$c<= :: TypeSpec -> TypeSpec -> Bool
<= :: TypeSpec -> TypeSpec -> Bool
$c> :: TypeSpec -> TypeSpec -> Bool
> :: TypeSpec -> TypeSpec -> Bool
$c>= :: TypeSpec -> TypeSpec -> Bool
>= :: TypeSpec -> TypeSpec -> Bool
$cmax :: TypeSpec -> TypeSpec -> TypeSpec
max :: TypeSpec -> TypeSpec -> TypeSpec
$cmin :: TypeSpec -> TypeSpec -> TypeSpec
min :: TypeSpec -> TypeSpec -> TypeSpec
Ord, Int -> TypeSpec -> ShowS
[TypeSpec] -> ShowS
TypeSpec -> [Char]
(Int -> TypeSpec -> ShowS)
-> (TypeSpec -> [Char]) -> ([TypeSpec] -> ShowS) -> Show TypeSpec
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TypeSpec -> ShowS
showsPrec :: Int -> TypeSpec -> ShowS
$cshow :: TypeSpec -> [Char]
show :: TypeSpec -> [Char]
$cshowList :: [TypeSpec] -> ShowS
showList :: [TypeSpec] -> ShowS
Show)

-- | Documented custom type.
data TypeDocs = TypeDocs
  { TypeDocs -> Text
typeDescription :: Text
  , TypeDocs -> TypeSpec
typeSpec        :: TypeSpec
  , TypeDocs -> Maybe Name
typeRegistry    :: Maybe Name
  }
  deriving (TypeDocs -> TypeDocs -> Bool
(TypeDocs -> TypeDocs -> Bool)
-> (TypeDocs -> TypeDocs -> Bool) -> Eq TypeDocs
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TypeDocs -> TypeDocs -> Bool
== :: TypeDocs -> TypeDocs -> Bool
$c/= :: TypeDocs -> TypeDocs -> Bool
/= :: TypeDocs -> TypeDocs -> Bool
Eq, (forall x. TypeDocs -> Rep TypeDocs x)
-> (forall x. Rep TypeDocs x -> TypeDocs) -> Generic TypeDocs
forall x. Rep TypeDocs x -> TypeDocs
forall x. TypeDocs -> Rep TypeDocs x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TypeDocs -> Rep TypeDocs x
from :: forall x. TypeDocs -> Rep TypeDocs x
$cto :: forall x. Rep TypeDocs x -> TypeDocs
to :: forall x. Rep TypeDocs x -> TypeDocs
Generic, Eq TypeDocs
Eq TypeDocs =>
(TypeDocs -> TypeDocs -> Ordering)
-> (TypeDocs -> TypeDocs -> Bool)
-> (TypeDocs -> TypeDocs -> Bool)
-> (TypeDocs -> TypeDocs -> Bool)
-> (TypeDocs -> TypeDocs -> Bool)
-> (TypeDocs -> TypeDocs -> TypeDocs)
-> (TypeDocs -> TypeDocs -> TypeDocs)
-> Ord TypeDocs
TypeDocs -> TypeDocs -> Bool
TypeDocs -> TypeDocs -> Ordering
TypeDocs -> TypeDocs -> TypeDocs
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: TypeDocs -> TypeDocs -> Ordering
compare :: TypeDocs -> TypeDocs -> Ordering
$c< :: TypeDocs -> TypeDocs -> Bool
< :: TypeDocs -> TypeDocs -> Bool
$c<= :: TypeDocs -> TypeDocs -> Bool
<= :: TypeDocs -> TypeDocs -> Bool
$c> :: TypeDocs -> TypeDocs -> Bool
> :: TypeDocs -> TypeDocs -> Bool
$c>= :: TypeDocs -> TypeDocs -> Bool
>= :: TypeDocs -> TypeDocs -> Bool
$cmax :: TypeDocs -> TypeDocs -> TypeDocs
max :: TypeDocs -> TypeDocs -> TypeDocs
$cmin :: TypeDocs -> TypeDocs -> TypeDocs
min :: TypeDocs -> TypeDocs -> TypeDocs
Ord, Int -> TypeDocs -> ShowS
[TypeDocs] -> ShowS
TypeDocs -> [Char]
(Int -> TypeDocs -> ShowS)
-> (TypeDocs -> [Char]) -> ([TypeDocs] -> ShowS) -> Show TypeDocs
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TypeDocs -> ShowS
showsPrec :: Int -> TypeDocs -> ShowS
$cshow :: TypeDocs -> [Char]
show :: TypeDocs -> [Char]
$cshowList :: [TypeDocs] -> ShowS
showList :: [TypeDocs] -> ShowS
Show)

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

-- | Generate a string representation of the type specifier.
typeSpecToString :: TypeSpec -> String
typeSpecToString :: TypeSpec -> [Char]
typeSpecToString = \case
  BasicType Type
t   -> Type -> [Char]
basicTypeName Type
t
  NamedType Name
nt  -> ByteString -> [Char]
toString (ByteString -> [Char]) -> ByteString -> [Char]
forall a b. (a -> b) -> a -> b
$ Name -> ByteString
fromName Name
nt
  TypeSpec
AnyType       -> [Char]
"any"
  FunType{}     -> [Char]
"function"
  RecType{}     -> [Char]
"table"
  SeqType TypeSpec
t     -> Char
'{' Char -> ShowS
forall a. a -> [a] -> [a]
: TypeSpec -> [Char]
typeSpecToString TypeSpec
t [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
",...}"
  SumType [TypeSpec]
specs -> [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"|" ((TypeSpec -> [Char]) -> [TypeSpec] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map TypeSpec -> [Char]
typeSpecToString [TypeSpec]
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 :: [Char] -> TypeSpec
typeSpecFromString = \case
  [Char]
"any"            -> TypeSpec
anyType
  [Char]
"boolean"        -> TypeSpec
booleanType
  [Char]
"function"       -> TypeSpec
functionType
  [Char]
"integer"        -> TypeSpec
integerType
  [Char]
"light userdata" -> TypeSpec
lightUserdataType
  [Char]
"nil"            -> TypeSpec
nilType
  [Char]
"number"         -> TypeSpec
numberType
  [Char]
"string"         -> TypeSpec
stringType
  [Char]
"table"          -> TypeSpec
tableType
  [Char]
"userdata"       -> TypeSpec
userdataType
  [Char]
s                -> case ((TypeSpec, [Char]) -> Bool)
-> [(TypeSpec, [Char])] -> Maybe (TypeSpec, [Char])
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (TypeSpec, [Char]) -> Bool
forall {a} {a}. (a, [a]) -> Bool
completeParse (ReadP TypeSpec -> ReadS TypeSpec
forall a. ReadP a -> ReadS a
readP_to_S ReadP TypeSpec
pTypeSpec [Char]
s) of
                        Maybe (TypeSpec, [Char])
Nothing -> Name -> TypeSpec
NamedType ([Char] -> Name
forall a. IsString a => [Char] -> a
fromString [Char]
s)  -- Parsing failed
                        Just (TypeSpec
x,[Char]
_) -> TypeSpec
x
 where completeParse :: (a, [a]) -> Bool
completeParse = [a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([a] -> Bool) -> ((a, [a]) -> [a]) -> (a, [a]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, [a]) -> [a]
forall a b. (a, b) -> b
snd

pTypeSpec :: ReadP TypeSpec
pTypeSpec :: ReadP TypeSpec
pTypeSpec = (TypeSpec -> TypeSpec -> TypeSpec)
-> TypeSpec -> [TypeSpec] -> TypeSpec
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TypeSpec -> TypeSpec -> TypeSpec
(#|#) TypeSpec
voidType ([TypeSpec] -> TypeSpec) -> ReadP [TypeSpec] -> ReadP TypeSpec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP TypeSpec -> ReadP Char -> ReadP [TypeSpec]
forall a sep. ReadP a -> ReadP sep -> ReadP [a]
sepBy (ReadP TypeSpec
pAtomic ReadP TypeSpec -> ReadP TypeSpec -> ReadP TypeSpec
forall a. ReadP a -> ReadP a -> ReadP a
<++ ReadP TypeSpec
pSeq) (Char -> ReadP Char
char Char
'|')

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

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

    pEllipsis :: ReadP String
    pEllipsis :: ReadP [Char]
pEllipsis = [Char] -> ReadP [Char]
string [Char]
"..." ReadP [Char] -> ReadP () -> ReadP [Char]
forall a b. ReadP a -> ReadP b -> ReadP a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadP ()
skipSpaces

--
-- Built-in types
--

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

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

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

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

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

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

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

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

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

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

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

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

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

--
-- Constructors
--

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

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

--
-- Marshalling
--

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

-- | Retrieves a custom type specifier.
peekTypeDoc :: LuaError e => Peeker e TypeDocs
peekTypeDoc :: forall e. LuaError e => Peeker e TypeDocs
peekTypeDoc = Name
-> (StackIndex -> LuaE e Bool)
-> Peeker e TypeDocs
-> Peeker e TypeDocs
forall e a.
Name -> (StackIndex -> LuaE e Bool) -> Peeker e a -> Peeker e a
typeChecked Name
"TypeDoc" StackIndex -> LuaE e Bool
forall e. StackIndex -> LuaE e Bool
istable (Peeker e TypeDocs -> Peeker e TypeDocs)
-> Peeker e TypeDocs -> Peeker e TypeDocs
forall a b. (a -> b) -> a -> b
$ \StackIndex
idx -> do
  LuaE e () -> Peek e ()
forall e a. LuaE e a -> Peek e a
liftLua (LuaE e () -> Peek e ()) -> LuaE e () -> Peek e ()
forall a b. (a -> b) -> a -> b
$ Int -> [Char] -> LuaE e ()
forall e. LuaError e => Int -> [Char] -> LuaE e ()
checkstack' Int
8 [Char]
"HsLua.Typing.peekTypeDoc"
  Text
desc <- Peeker e Text -> Name -> Peeker e Text
forall e a. LuaError e => Peeker e a -> Name -> Peeker e a
peekFieldRaw Peeker e Text
forall e. Peeker e Text
peekText Name
"description" StackIndex
idx
  TypeSpec
spec <- Peeker e TypeSpec -> Name -> Peeker e TypeSpec
forall e a. LuaError e => Peeker e a -> Name -> Peeker e a
peekFieldRaw Peeker e TypeSpec
forall e. LuaError e => Peeker e TypeSpec
peekTypeSpec Name
"typespec" StackIndex
idx
  Maybe Name
regn <- Peeker e (Maybe Name) -> Name -> Peeker e (Maybe Name)
forall e a. LuaError e => Peeker e a -> Name -> Peeker e a
peekFieldRaw (Peeker e Name -> Peeker e (Maybe Name)
forall (m :: * -> *) e a.
Alternative m =>
Peeker e a -> Peeker e (m a)
peekNilOr Peeker e Name
forall e. Peeker e Name
peekName) Name
"registry" StackIndex
idx
  TypeDocs -> Peek e TypeDocs
forall a. a -> Peek e a
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeDocs -> Peek e TypeDocs) -> TypeDocs -> Peek e TypeDocs
forall a b. (a -> b) -> a -> b
$ Text -> TypeSpec -> Maybe Name -> TypeDocs
TypeDocs Text
desc TypeSpec
spec Maybe Name
regn

-- | Pushes a table representation of a 'TypeSpec' to the stack.
pushTypeSpec :: LuaError e
             => TypeSpec
             -> LuaE e ()
pushTypeSpec :: forall e. LuaError e => TypeSpec -> LuaE e ()
pushTypeSpec TypeSpec
ts = do
  Int -> [Char] -> LuaE e ()
forall e. LuaError e => Int -> [Char] -> LuaE e ()
checkstack' Int
8 [Char]
"HsLua.Typing.pushTypeSpec"
  case TypeSpec
ts of
    BasicType Type
bt  -> [(Name, Type -> LuaE e ())] -> Type -> LuaE e ()
forall e a.
LuaError e =>
[(Name, a -> LuaE e ())] -> a -> LuaE e ()
pushAsTable [(Name
"basic", [Char] -> LuaE e ()
forall e. [Char] -> LuaE e ()
pushString ([Char] -> LuaE e ()) -> (Type -> [Char]) -> Type -> LuaE e ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> [Char]
basicTypeName)] Type
bt
    NamedType Name
n   -> [(Name, Name -> LuaE e ())] -> Name -> LuaE e ()
forall e a.
LuaError e =>
[(Name, a -> LuaE e ())] -> a -> LuaE e ()
pushAsTable [(Name
"named", Name -> LuaE e ()
forall e. Name -> LuaE e ()
pushName)] Name
n
    SeqType TypeSpec
seq'  -> [(Name, TypeSpec -> LuaE e ())] -> TypeSpec -> LuaE e ()
forall e a.
LuaError e =>
[(Name, a -> LuaE e ())] -> a -> LuaE e ()
pushAsTable [(Name
"sequence", TypeSpec -> LuaE e ()
forall e. LuaError e => TypeSpec -> LuaE e ()
pushTypeSpec)] TypeSpec
seq'
    SumType [TypeSpec]
st    -> [(Name, [TypeSpec] -> LuaE e ())] -> [TypeSpec] -> LuaE e ()
forall e a.
LuaError e =>
[(Name, a -> LuaE e ())] -> a -> LuaE e ()
pushAsTable [(Name
"sum", (TypeSpec -> LuaE e ()) -> [TypeSpec] -> LuaE e ()
forall e a. LuaError e => Pusher e a -> [a] -> LuaE e ()
pushList TypeSpec -> LuaE e ()
forall e. LuaError e => TypeSpec -> LuaE e ()
pushTypeSpec)] [TypeSpec]
st
    RecType Map Name TypeSpec
rt    -> [(Name, Map Name TypeSpec -> LuaE e ())]
-> Map Name TypeSpec -> LuaE e ()
forall e a.
LuaError e =>
[(Name, a -> LuaE e ())] -> a -> LuaE e ()
pushAsTable [(Name
"record", (Name -> LuaE e ())
-> (TypeSpec -> LuaE e ()) -> Map Name TypeSpec -> LuaE e ()
forall e a b.
LuaError e =>
Pusher e a -> Pusher e b -> Pusher e (Map a b)
pushMap Name -> LuaE e ()
forall e. Name -> LuaE e ()
pushName TypeSpec -> LuaE e ()
forall e. LuaError e => TypeSpec -> LuaE e ()
pushTypeSpec)] Map Name TypeSpec
rt
    FunType [TypeSpec]
dt [TypeSpec]
ct -> [(Name, ([TypeSpec], [TypeSpec]) -> LuaE e ())]
-> ([TypeSpec], [TypeSpec]) -> LuaE e ()
forall e a.
LuaError e =>
[(Name, a -> LuaE e ())] -> a -> LuaE e ()
pushAsTable [(Name
"domain", (TypeSpec -> LuaE e ()) -> [TypeSpec] -> LuaE e ()
forall e a. LuaError e => Pusher e a -> [a] -> LuaE e ()
pushList TypeSpec -> LuaE e ()
forall e. LuaError e => TypeSpec -> LuaE e ()
pushTypeSpec ([TypeSpec] -> LuaE e ())
-> (([TypeSpec], [TypeSpec]) -> [TypeSpec])
-> ([TypeSpec], [TypeSpec])
-> LuaE e ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([TypeSpec], [TypeSpec]) -> [TypeSpec]
forall a b. (a, b) -> a
fst)
                                 ,(Name
"codomain", (TypeSpec -> LuaE e ()) -> [TypeSpec] -> LuaE e ()
forall e a. LuaError e => Pusher e a -> [a] -> LuaE e ()
pushList TypeSpec -> LuaE e ()
forall e. LuaError e => TypeSpec -> LuaE e ()
pushTypeSpec ([TypeSpec] -> LuaE e ())
-> (([TypeSpec], [TypeSpec]) -> [TypeSpec])
-> ([TypeSpec], [TypeSpec])
-> LuaE e ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([TypeSpec], [TypeSpec]) -> [TypeSpec]
forall a b. (a, b) -> b
snd)]
                                 ([TypeSpec]
dt, [TypeSpec]
ct)
    TypeSpec
AnyType       -> [(Name, Bool -> LuaE e ())] -> Bool -> LuaE e ()
forall e a.
LuaError e =>
[(Name, a -> LuaE e ())] -> a -> LuaE e ()
pushAsTable [(Name
"any", Bool -> LuaE e ()
forall e. Pusher e Bool
pushBool)] Bool
True
  Bool
created <- Name -> LuaE e Bool
forall e. Name -> LuaE e Bool
newmetatable Name
"HsLua.TypeSpec"
  Bool -> LuaE e () -> LuaE e ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
created (LuaE e () -> LuaE e ()) -> LuaE e () -> LuaE e ()
forall a b. (a -> b) -> a -> b
$ do
    HaskellFunction e -> LuaE e ()
forall e. LuaError e => HaskellFunction e -> LuaE e ()
pushHaskellFunction (HaskellFunction e -> LuaE e ()) -> HaskellFunction e -> LuaE e ()
forall a b. (a -> b) -> a -> b
$ do
      TypeSpec
ts' <- Peek e TypeSpec -> LuaE e TypeSpec
forall e a. LuaError e => Peek e a -> LuaE e a
forcePeek (Peek e TypeSpec -> LuaE e TypeSpec)
-> Peek e TypeSpec -> LuaE e TypeSpec
forall a b. (a -> b) -> a -> b
$ Peeker e TypeSpec
forall e. LuaError e => Peeker e TypeSpec
peekTypeSpec (CInt -> StackIndex
nth CInt
1)
      [Char] -> LuaE e ()
forall e. [Char] -> LuaE e ()
pushString ([Char] -> LuaE e ()) -> [Char] -> LuaE e ()
forall a b. (a -> b) -> a -> b
$ TypeSpec -> [Char]
typeSpecToString TypeSpec
ts'
      NumResults -> HaskellFunction e
forall a. a -> LuaE e a
forall (m :: * -> *) a. Monad m => a -> m a
return NumResults
1
    StackIndex -> Name -> LuaE e ()
forall e. LuaError e => StackIndex -> Name -> LuaE e ()
setfield (CInt -> StackIndex
nth CInt
2) Name
"__tostring"
  StackIndex -> LuaE e ()
forall e. StackIndex -> LuaE e ()
setmetatable (CInt -> StackIndex
nth CInt
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 :: Type -> [Char]
basicTypeName = \case
  Type
TypeLightUserdata -> [Char]
"light userdata"
  Type
t                 -> (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
4 ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Type -> [Char]
forall a. Show a => a -> [Char]
show Type
t

-- | Retrieves a 'TypeSpec' from a table on the stack.
peekTypeSpec :: LuaError e => Peeker e TypeSpec
peekTypeSpec :: forall e. LuaError e => Peeker e TypeSpec
peekTypeSpec = Name
-> (StackIndex -> LuaE e Bool)
-> Peeker e TypeSpec
-> Peeker e TypeSpec
forall e a.
Name -> (StackIndex -> LuaE e Bool) -> Peeker e a -> Peeker e a
typeChecked Name
"TypeSpec" StackIndex -> LuaE e Bool
forall e. StackIndex -> LuaE e Bool
istable (Peeker e TypeSpec -> Peeker e TypeSpec)
-> Peeker e TypeSpec -> Peeker e TypeSpec
forall a b. (a -> b) -> a -> b
$ \StackIndex
idx -> do
  LuaE e () -> Peek e ()
forall e a. LuaE e a -> Peek e a
liftLua (LuaE e () -> Peek e ()) -> LuaE e () -> Peek e ()
forall a b. (a -> b) -> a -> b
$ Int -> [Char] -> LuaE e ()
forall e. LuaError e => Int -> [Char] -> LuaE e ()
checkstack' Int
8 [Char]
"HsLua.Typing.peekTypeSpec"
  [Peeker e TypeSpec] -> Peeker e TypeSpec
forall e a. LuaError e => [Peeker e a] -> Peeker e a
choice
    [ (Type -> TypeSpec) -> Peek e Type -> Peek e TypeSpec
forall a b. (a -> b) -> Peek e a -> Peek e b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> TypeSpec
BasicType (Peek e Type -> Peek e TypeSpec)
-> (StackIndex -> Peek e Type) -> Peeker e TypeSpec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StackIndex -> Peek e Type) -> Name -> StackIndex -> Peek e Type
forall e a. LuaError e => Peeker e a -> Name -> Peeker e a
peekFieldRaw StackIndex -> Peek e Type
forall {e}. StackIndex -> Peek e Type
peekBasicType Name
"basic"
    , (Name -> TypeSpec) -> Peek e Name -> Peek e TypeSpec
forall a b. (a -> b) -> Peek e a -> Peek e b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> TypeSpec
NamedType (Peek e Name -> Peek e TypeSpec)
-> (StackIndex -> Peek e Name) -> Peeker e TypeSpec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StackIndex -> Peek e Name) -> Name -> StackIndex -> Peek e Name
forall e a. LuaError e => Peeker e a -> Name -> Peeker e a
peekFieldRaw StackIndex -> Peek e Name
forall e. Peeker e Name
peekName Name
"named"
    , (TypeSpec -> TypeSpec) -> Peek e TypeSpec -> Peek e TypeSpec
forall a b. (a -> b) -> Peek e a -> Peek e b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TypeSpec -> TypeSpec
SeqType (Peek e TypeSpec -> Peek e TypeSpec)
-> Peeker e TypeSpec -> Peeker e TypeSpec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Peeker e TypeSpec -> Name -> Peeker e TypeSpec
forall e a. LuaError e => Peeker e a -> Name -> Peeker e a
peekFieldRaw Peeker e TypeSpec
forall e. LuaError e => Peeker e TypeSpec
peekTypeSpec Name
"sequence"
    , ([TypeSpec] -> TypeSpec) -> Peek e [TypeSpec] -> Peek e TypeSpec
forall a b. (a -> b) -> Peek e a -> Peek e b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [TypeSpec] -> TypeSpec
SumType (Peek e [TypeSpec] -> Peek e TypeSpec)
-> (StackIndex -> Peek e [TypeSpec]) -> Peeker e TypeSpec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StackIndex -> Peek e [TypeSpec])
-> Name -> StackIndex -> Peek e [TypeSpec]
forall e a. LuaError e => Peeker e a -> Name -> Peeker e a
peekFieldRaw (Peeker e TypeSpec -> StackIndex -> Peek e [TypeSpec]
forall a e. LuaError e => Peeker e a -> Peeker e [a]
peekList Peeker e TypeSpec
forall e. LuaError e => Peeker e TypeSpec
peekTypeSpec) Name
"sum"
    , (Map Name TypeSpec -> TypeSpec)
-> Peek e (Map Name TypeSpec) -> Peek e TypeSpec
forall a b. (a -> b) -> Peek e a -> Peek e b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Map Name TypeSpec -> TypeSpec
RecType (Peek e (Map Name TypeSpec) -> Peek e TypeSpec)
-> (StackIndex -> Peek e (Map Name TypeSpec)) -> Peeker e TypeSpec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StackIndex -> Peek e (Map Name TypeSpec))
-> Name -> StackIndex -> Peek e (Map Name TypeSpec)
forall e a. LuaError e => Peeker e a -> Name -> Peeker e a
peekFieldRaw ((StackIndex -> Peek e Name)
-> Peeker e TypeSpec -> StackIndex -> Peek e (Map Name TypeSpec)
forall e a b.
(LuaError e, Ord a) =>
Peeker e a -> Peeker e b -> Peeker e (Map a b)
peekMap StackIndex -> Peek e Name
forall e. Peeker e Name
peekName Peeker e TypeSpec
forall e. LuaError e => Peeker e TypeSpec
peekTypeSpec) Name
"record"
    , \StackIndex
i -> do
        [TypeSpec]
dom <- (StackIndex -> Peek e [TypeSpec])
-> Name -> StackIndex -> Peek e [TypeSpec]
forall e a. LuaError e => Peeker e a -> Name -> Peeker e a
peekFieldRaw (Peeker e TypeSpec -> StackIndex -> Peek e [TypeSpec]
forall a e. LuaError e => Peeker e a -> Peeker e [a]
peekList Peeker e TypeSpec
forall e. LuaError e => Peeker e TypeSpec
peekTypeSpec) Name
"domain" StackIndex
i
        [TypeSpec]
cod <- (StackIndex -> Peek e [TypeSpec])
-> Name -> StackIndex -> Peek e [TypeSpec]
forall e a. LuaError e => Peeker e a -> Name -> Peeker e a
peekFieldRaw (Peeker e TypeSpec -> StackIndex -> Peek e [TypeSpec]
forall a e. LuaError e => Peeker e a -> Peeker e [a]
peekList Peeker e TypeSpec
forall e. LuaError e => Peeker e TypeSpec
peekTypeSpec) Name
"codomain" StackIndex
i
        TypeSpec -> Peek e TypeSpec
forall a. a -> Peek e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeSpec -> Peek e TypeSpec) -> TypeSpec -> Peek e TypeSpec
forall a b. (a -> b) -> a -> b
$ [TypeSpec] -> [TypeSpec] -> TypeSpec
FunType [TypeSpec]
dom [TypeSpec]
cod
    , Peek e TypeSpec -> Peeker e TypeSpec
forall a b. a -> b -> a
const (TypeSpec -> Peek e TypeSpec
forall a. a -> Peek e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeSpec
AnyType)
    ] StackIndex
idx
 where
  peekBasicType :: StackIndex -> Peek e Type
peekBasicType StackIndex
idx = Peeker e [Char]
forall e. Peeker e [Char]
peekString StackIndex
idx Peek e [Char] -> ([Char] -> Peek e Type) -> Peek e Type
forall a b. Peek e a -> (a -> Peek e b) -> Peek e b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    [Char]
"light userdata" -> Type -> Peek e Type
forall a. a -> Peek e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
TypeLightUserdata
    (Char
c:[Char]
cs)           -> Peek e Type -> (Type -> Peek e Type) -> Maybe Type -> Peek e Type
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> Peek e Type
forall a. [Char] -> Peek e a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"unknown type") Type -> Peek e Type
forall a. a -> Peek e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Type -> Peek e Type) -> Maybe Type -> Peek e Type
forall a b. (a -> b) -> a -> b
$
                        [Char] -> Maybe Type
forall a. Read a => [Char] -> Maybe a
readMaybe ([Char]
"Type" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Char -> Char
toUpper Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: [Char]
cs)
    [Char]
_                -> ByteString -> Peek e Type
forall a e. ByteString -> Peek e a
failPeek ByteString
"invalid type string"