{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-|
Module      : HsLua.Typing
Copyright   : © 2023 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TypeSpec -> TypeSpec -> Bool
$c/= :: TypeSpec -> TypeSpec -> Bool
== :: TypeSpec -> TypeSpec -> Bool
$c== :: TypeSpec -> TypeSpec -> Bool
Eq, 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
$cto :: forall x. Rep TypeSpec x -> TypeSpec
$cfrom :: forall x. TypeSpec -> Rep TypeSpec x
Generic, Eq 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
min :: TypeSpec -> TypeSpec -> TypeSpec
$cmin :: TypeSpec -> TypeSpec -> TypeSpec
max :: TypeSpec -> TypeSpec -> TypeSpec
$cmax :: TypeSpec -> TypeSpec -> TypeSpec
>= :: TypeSpec -> TypeSpec -> Bool
$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
compare :: TypeSpec -> TypeSpec -> Ordering
$ccompare :: TypeSpec -> TypeSpec -> Ordering
Ord, Int -> TypeSpec -> ShowS
[TypeSpec] -> ShowS
TypeSpec -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [TypeSpec] -> ShowS
$cshowList :: [TypeSpec] -> ShowS
show :: TypeSpec -> [Char]
$cshow :: TypeSpec -> [Char]
showsPrec :: Int -> TypeSpec -> ShowS
$cshowsPrec :: Int -> 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TypeDocs -> TypeDocs -> Bool
$c/= :: TypeDocs -> TypeDocs -> Bool
== :: TypeDocs -> TypeDocs -> Bool
$c== :: TypeDocs -> TypeDocs -> Bool
Eq, 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
$cto :: forall x. Rep TypeDocs x -> TypeDocs
$cfrom :: forall x. TypeDocs -> Rep TypeDocs x
Generic, Eq 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
min :: TypeDocs -> TypeDocs -> TypeDocs
$cmin :: TypeDocs -> TypeDocs -> TypeDocs
max :: TypeDocs -> TypeDocs -> TypeDocs
$cmax :: TypeDocs -> TypeDocs -> TypeDocs
>= :: TypeDocs -> TypeDocs -> Bool
$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
compare :: TypeDocs -> TypeDocs -> Ordering
$ccompare :: TypeDocs -> TypeDocs -> Ordering
Ord, Int -> TypeDocs -> ShowS
[TypeDocs] -> ShowS
TypeDocs -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [TypeDocs] -> ShowS
$cshowList :: [TypeDocs] -> ShowS
show :: TypeDocs -> [Char]
$cshow :: TypeDocs -> [Char]
showsPrec :: Int -> TypeDocs -> ShowS
$cshowsPrec :: Int -> 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 forall a. [a] -> [a] -> [a]
++ [TypeSpec]
b)
SumType [TypeSpec]
a  #|# TypeSpec
b          = [TypeSpec] -> TypeSpec
SumType ([TypeSpec]
a forall a. [a] -> [a] -> [a]
++ [TypeSpec
b])
TypeSpec
a          #|# SumType [TypeSpec]
b  = [TypeSpec] -> TypeSpec
SumType (TypeSpec
a forall a. a -> [a] -> [a]
: [TypeSpec]
b)
TypeSpec
a          #|# TypeSpec
b          =
  if TypeSpec
a 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 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
'{' forall a. a -> [a] -> [a]
: TypeSpec -> [Char]
typeSpecToString TypeSpec
t forall a. [a] -> [a] -> [a]
++ [Char]
",...}"
  SumType [TypeSpec]
specs -> forall a. [a] -> [[a]] -> [a]
intercalate [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 forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find forall {a} {a}. (a, [a]) -> Bool
completeParse (forall a. ReadP a -> ReadS a
readP_to_S ReadP TypeSpec
pTypeSpec [Char]
s) of
                        Maybe (TypeSpec, [Char])
Nothing -> Name -> TypeSpec
NamedType (forall a. IsString a => [Char] -> a
fromString [Char]
s)  -- Parsing failed
                        Just (TypeSpec
x,[Char]
_) -> TypeSpec
x
 where completeParse :: (a, [a]) -> Bool
completeParse = forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd

pTypeSpec :: ReadP TypeSpec
pTypeSpec :: ReadP TypeSpec
pTypeSpec = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TypeSpec -> TypeSpec -> TypeSpec
(#|#) TypeSpec
voidType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a sep. ReadP a -> ReadP sep -> ReadP [a]
sepBy (ReadP TypeSpec
pAtomic 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 <- forall a. ReadP a -> ReadP [a]
many1 ((Char -> Bool) -> ReadP Char
satisfy (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Char
'{', Char
'}', Char
'|', Char
',']))
  forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 (forall a. IsString a => [Char] -> a
fromString [Char]
str)

-- | Parses a sequence type.
pSeq :: ReadP TypeSpec
pSeq :: ReadP TypeSpec
pSeq = TypeSpec -> TypeSpec
seqType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> ReadP Char
char Char
'{' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ReadP TypeSpec
pTypeSpec forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadP Char
pComma forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadP [Char]
pEllipsis 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 forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> ReadP Char
char Char
',' 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]
"..." 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
  forall e. LuaError e => Int -> [Char] -> LuaE e ()
checkstack' Int
8 [Char]
"HsLua.Typing.pushTypeDoc"
  forall e a.
LuaError e =>
[(Name, a -> LuaE e ())] -> a -> LuaE e ()
pushAsTable
    [ (Name
"description", forall e. Pusher e Text
pushText forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeDocs -> Text
typeDescription)
    , (Name
"typespec", forall e. LuaError e => TypeSpec -> LuaE e ()
pushTypeSpec forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeDocs -> TypeSpec
typeSpec)
    , (Name
"registry", forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall e. LuaE e ()
pushnil forall e. Name -> LuaE e ()
pushName 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 = forall e a.
Name -> (StackIndex -> LuaE e Bool) -> Peeker e a -> Peeker e a
typeChecked Name
"TypeDoc" forall e. StackIndex -> LuaE e Bool
istable forall a b. (a -> b) -> a -> b
$ \StackIndex
idx -> do
  forall e a. LuaE e a -> Peek e a
liftLua forall a b. (a -> b) -> a -> b
$ forall e. LuaError e => Int -> [Char] -> LuaE e ()
checkstack' Int
8 [Char]
"HsLua.Typing.peekTypeDoc"
  Text
desc <- forall e a. LuaError e => Peeker e a -> Name -> Peeker e a
peekFieldRaw forall e. Peeker e Text
peekText Name
"description" StackIndex
idx
  TypeSpec
spec <- forall e a. LuaError e => Peeker e a -> Name -> Peeker e a
peekFieldRaw forall e. LuaError e => Peeker e TypeSpec
peekTypeSpec Name
"typespec" StackIndex
idx
  Maybe Name
regn <- forall e a. LuaError e => Peeker e a -> Name -> Peeker e a
peekFieldRaw (forall (m :: * -> *) e a.
Alternative m =>
Peeker e a -> Peeker e (m a)
peekNilOr forall e. Peeker e Name
peekName) Name
"registry" StackIndex
idx
  forall (m :: * -> *) a. Monad m => a -> m a
return 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
  forall e. LuaError e => Int -> [Char] -> LuaE e ()
checkstack' Int
8 [Char]
"HsLua.Typing.pushTypeSpec"
  case TypeSpec
ts of
    BasicType Type
bt  -> forall e a.
LuaError e =>
[(Name, a -> LuaE e ())] -> a -> LuaE e ()
pushAsTable [(Name
"basic", forall e. [Char] -> LuaE e ()
pushString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> [Char]
basicTypeName)] Type
bt
    NamedType Name
n   -> forall e a.
LuaError e =>
[(Name, a -> LuaE e ())] -> a -> LuaE e ()
pushAsTable [(Name
"named", forall e. Name -> LuaE e ()
pushName)] Name
n
    SeqType TypeSpec
seq'  -> forall e a.
LuaError e =>
[(Name, a -> LuaE e ())] -> a -> LuaE e ()
pushAsTable [(Name
"sequence", forall e. LuaError e => TypeSpec -> LuaE e ()
pushTypeSpec)] TypeSpec
seq'
    SumType [TypeSpec]
st    -> forall e a.
LuaError e =>
[(Name, a -> LuaE e ())] -> a -> LuaE e ()
pushAsTable [(Name
"sum", forall e a. LuaError e => Pusher e a -> [a] -> LuaE e ()
pushList forall e. LuaError e => TypeSpec -> LuaE e ()
pushTypeSpec)] [TypeSpec]
st
    RecType Map Name TypeSpec
rt    -> forall e a.
LuaError e =>
[(Name, a -> LuaE e ())] -> a -> LuaE e ()
pushAsTable [(Name
"record", forall e a b.
LuaError e =>
Pusher e a -> Pusher e b -> Pusher e (Map a b)
pushMap forall e. Name -> LuaE e ()
pushName forall e. LuaError e => TypeSpec -> LuaE e ()
pushTypeSpec)] Map Name TypeSpec
rt
    FunType [TypeSpec]
dt [TypeSpec]
ct -> forall e a.
LuaError e =>
[(Name, a -> LuaE e ())] -> a -> LuaE e ()
pushAsTable [(Name
"domain", forall e a. LuaError e => Pusher e a -> [a] -> LuaE e ()
pushList forall e. LuaError e => TypeSpec -> LuaE e ()
pushTypeSpec forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
                                 ,(Name
"codomain", forall e a. LuaError e => Pusher e a -> [a] -> LuaE e ()
pushList forall e. LuaError e => TypeSpec -> LuaE e ()
pushTypeSpec forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)]
                                 ([TypeSpec]
dt, [TypeSpec]
ct)
    TypeSpec
AnyType       -> forall e a.
LuaError e =>
[(Name, a -> LuaE e ())] -> a -> LuaE e ()
pushAsTable [(Name
"any", forall e. Pusher e Bool
pushBool)] Bool
True
  Bool
created <- forall e. Name -> LuaE e Bool
newmetatable Name
"HsLua.TypeSpec"
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
created forall a b. (a -> b) -> a -> b
$ do
    forall e. LuaError e => HaskellFunction e -> LuaE e ()
pushHaskellFunction forall a b. (a -> b) -> a -> b
$ do
      TypeSpec
ts' <- forall e a. LuaError e => Peek e a -> LuaE e a
forcePeek forall a b. (a -> b) -> a -> b
$ forall e. LuaError e => Peeker e TypeSpec
peekTypeSpec (CInt -> StackIndex
nth CInt
1)
      forall e. [Char] -> LuaE e ()
pushString forall a b. (a -> b) -> a -> b
$ TypeSpec -> [Char]
typeSpecToString TypeSpec
ts'
      forall (m :: * -> *) a. Monad m => a -> m a
return NumResults
1
    forall e. LuaError e => StackIndex -> Name -> LuaE e ()
setfield (CInt -> StackIndex
nth CInt
2) Name
"__tostring"
  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                 -> forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
4 forall a b. (a -> b) -> a -> b
$ 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 = forall e a.
Name -> (StackIndex -> LuaE e Bool) -> Peeker e a -> Peeker e a
typeChecked Name
"TypeSpec" forall e. StackIndex -> LuaE e Bool
istable forall a b. (a -> b) -> a -> b
$ \StackIndex
idx -> do
  forall e a. LuaE e a -> Peek e a
liftLua forall a b. (a -> b) -> a -> b
$ forall e. LuaError e => Int -> [Char] -> LuaE e ()
checkstack' Int
8 [Char]
"HsLua.Typing.peekTypeSpec"
  forall e a. LuaError e => [Peeker e a] -> Peeker e a
choice
    [ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> TypeSpec
BasicType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. LuaError e => Peeker e a -> Name -> Peeker e a
peekFieldRaw forall {e}. StackIndex -> Peek e Type
peekBasicType Name
"basic"
    , forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> TypeSpec
NamedType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. LuaError e => Peeker e a -> Name -> Peeker e a
peekFieldRaw forall e. Peeker e Name
peekName Name
"named"
    , forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TypeSpec -> TypeSpec
SeqType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. LuaError e => Peeker e a -> Name -> Peeker e a
peekFieldRaw forall e. LuaError e => Peeker e TypeSpec
peekTypeSpec Name
"sequence"
    , forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [TypeSpec] -> TypeSpec
SumType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. LuaError e => Peeker e a -> Name -> Peeker e a
peekFieldRaw (forall a e. LuaError e => Peeker e a -> Peeker e [a]
peekList forall e. LuaError e => Peeker e TypeSpec
peekTypeSpec) Name
"sum"
    , forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Map Name TypeSpec -> TypeSpec
RecType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. LuaError e => Peeker e a -> Name -> Peeker e a
peekFieldRaw (forall e a b.
(LuaError e, Ord a) =>
Peeker e a -> Peeker e b -> Peeker e (Map a b)
peekMap forall e. Peeker e Name
peekName forall e. LuaError e => Peeker e TypeSpec
peekTypeSpec) Name
"record"
    , \StackIndex
i -> do
        [TypeSpec]
dom <- forall e a. LuaError e => Peeker e a -> Name -> Peeker e a
peekFieldRaw (forall a e. LuaError e => Peeker e a -> Peeker e [a]
peekList forall e. LuaError e => Peeker e TypeSpec
peekTypeSpec) Name
"domain" StackIndex
i
        [TypeSpec]
cod <- forall e a. LuaError e => Peeker e a -> Name -> Peeker e a
peekFieldRaw (forall a e. LuaError e => Peeker e a -> Peeker e [a]
peekList forall e. LuaError e => Peeker e TypeSpec
peekTypeSpec) Name
"codomain" StackIndex
i
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [TypeSpec] -> [TypeSpec] -> TypeSpec
FunType [TypeSpec]
dom [TypeSpec]
cod
    , forall a b. a -> b -> a
const (forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeSpec
AnyType)
    ] StackIndex
idx
 where
  peekBasicType :: StackIndex -> Peek e Type
peekBasicType StackIndex
idx = forall e. Peeker e [Char]
peekString StackIndex
idx forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    [Char]
"light userdata" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
TypeLightUserdata
    (Char
c:[Char]
cs)           -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"unknown type") forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
                        forall a. Read a => [Char] -> Maybe a
readMaybe ([Char]
"Type" forall a. [a] -> [a] -> [a]
++ Char -> Char
toUpper Char
c forall a. a -> [a] -> [a]
: [Char]
cs)
    [Char]
_                -> forall a e. ByteString -> Peek e a
failPeek ByteString
"invalid type string"