{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module HsLua.Typing
( TypeSpec (..)
, TypeDocs (..)
, (#|#)
, typeSpecToString
, typeSpecFromString
, anyType
, voidType
, booleanType
, functionType
, integerType
, lightUserdataType
, nilType
, numberType
, stringType
, tableType
, threadType
, userdataType
, recType
, seqType
, 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
data TypeSpec =
BasicType HsLua.Type
| NamedType Name
| SeqType TypeSpec
| SumType [TypeSpec]
| RecType (Map.Map Name TypeSpec)
| FunType [TypeSpec] [TypeSpec]
| AnyType
deriving (TypeSpec -> TypeSpec -> Bool
(TypeSpec -> TypeSpec -> Bool)
-> (TypeSpec -> TypeSpec -> Bool) -> Eq TypeSpec
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. 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
$cto :: forall x. Rep TypeSpec x -> TypeSpec
$cfrom :: forall x. TypeSpec -> Rep TypeSpec x
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
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
$cp1Ord :: Eq TypeSpec
Ord, Int -> TypeSpec -> ShowS
[TypeSpec] -> ShowS
TypeSpec -> String
(Int -> TypeSpec -> ShowS)
-> (TypeSpec -> String) -> ([TypeSpec] -> ShowS) -> Show TypeSpec
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TypeSpec] -> ShowS
$cshowList :: [TypeSpec] -> ShowS
show :: TypeSpec -> String
$cshow :: TypeSpec -> String
showsPrec :: Int -> TypeSpec -> ShowS
$cshowsPrec :: Int -> TypeSpec -> ShowS
Show)
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
/= :: TypeDocs -> TypeDocs -> Bool
$c/= :: TypeDocs -> TypeDocs -> Bool
== :: TypeDocs -> TypeDocs -> Bool
$c== :: 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
$cto :: forall x. Rep TypeDocs x -> TypeDocs
$cfrom :: forall x. TypeDocs -> Rep TypeDocs x
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
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
$cp1Ord :: Eq TypeDocs
Ord, Int -> TypeDocs -> ShowS
[TypeDocs] -> ShowS
TypeDocs -> String
(Int -> TypeDocs -> ShowS)
-> (TypeDocs -> String) -> ([TypeDocs] -> ShowS) -> Show TypeDocs
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TypeDocs] -> ShowS
$cshowList :: [TypeDocs] -> ShowS
show :: TypeDocs -> String
$cshow :: TypeDocs -> String
showsPrec :: Int -> TypeDocs -> ShowS
$cshowsPrec :: Int -> TypeDocs -> ShowS
Show)
(#|#) :: TypeSpec -> TypeSpec -> TypeSpec
TypeSpec
AnyType #|# :: TypeSpec -> TypeSpec -> TypeSpec
#|# TypeSpec
_ = TypeSpec
AnyType
TypeSpec
_ #|# TypeSpec
AnyType = TypeSpec
AnyType
SumType [] #|# TypeSpec
b = TypeSpec
b
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]
typeSpecToString :: TypeSpec -> String
typeSpecToString :: TypeSpec -> String
typeSpecToString = \case
BasicType Type
t -> Type -> String
basicTypeName Type
t
NamedType Name
nt -> ByteString -> String
toString (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Name -> ByteString
fromName Name
nt
TypeSpec
AnyType -> String
"any"
FunType{} -> String
"function"
RecType{} -> String
"table"
SeqType TypeSpec
t -> Char
'{' Char -> ShowS
forall a. a -> [a] -> [a]
: TypeSpec -> String
typeSpecToString TypeSpec
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
",...}"
SumType [TypeSpec]
specs -> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"|" ((TypeSpec -> String) -> [TypeSpec] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map TypeSpec -> String
typeSpecToString [TypeSpec]
specs)
typeSpecFromString :: String -> TypeSpec
typeSpecFromString :: String -> TypeSpec
typeSpecFromString = \case
String
"any" -> TypeSpec
anyType
String
"boolean" -> TypeSpec
booleanType
String
"function" -> TypeSpec
functionType
String
"integer" -> TypeSpec
integerType
String
"light userdata" -> TypeSpec
lightUserdataType
String
"nil" -> TypeSpec
nilType
String
"number" -> TypeSpec
numberType
String
"string" -> TypeSpec
stringType
String
"table" -> TypeSpec
tableType
String
"userdata" -> TypeSpec
userdataType
String
s -> case ((TypeSpec, String) -> Bool)
-> [(TypeSpec, String)] -> Maybe (TypeSpec, String)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (TypeSpec, String) -> Bool
forall a a. (a, [a]) -> Bool
completeParse (ReadP TypeSpec -> ReadS TypeSpec
forall a. ReadP a -> ReadS a
readP_to_S ReadP TypeSpec
pTypeSpec String
s) of
Maybe (TypeSpec, String)
Nothing -> Name -> TypeSpec
NamedType (String -> Name
forall a. IsString a => String -> a
fromString String
s)
Just (TypeSpec
x,String
_) -> TypeSpec
x
where completeParse :: (a, [a]) -> Bool
completeParse = [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 (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
'|')
pAtomic :: ReadP TypeSpec
pAtomic :: ReadP TypeSpec
pAtomic = do
String
str <- ReadP Char -> ReadP String
forall a. ReadP a -> ReadP [a]
many1 ((Char -> Bool) -> ReadP Char
satisfy (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Char
'{', Char
'}', Char
'|', Char
',']))
TypeSpec -> ReadP TypeSpec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeSpec -> ReadP TypeSpec) -> TypeSpec -> ReadP TypeSpec
forall a b. (a -> b) -> a -> b
$ case String
str of
String
"any" -> TypeSpec
anyType
String
"boolean" -> TypeSpec
booleanType
String
"function" -> TypeSpec
functionType
String
"integer" -> TypeSpec
integerType
String
"light userdata" -> TypeSpec
lightUserdataType
String
"nil" -> TypeSpec
nilType
String
"number" -> TypeSpec
numberType
String
"string" -> TypeSpec
stringType
String
"table" -> TypeSpec
tableType
String
"userdata" -> TypeSpec
userdataType
String
_ -> Name -> TypeSpec
NamedType (String -> Name
forall a. IsString a => String -> a
fromString String
str)
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 (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ReadP TypeSpec
pTypeSpec ReadP TypeSpec -> ReadP Char -> ReadP TypeSpec
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadP Char
pComma ReadP TypeSpec -> ReadP String -> ReadP TypeSpec
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadP String
pEllipsis ReadP TypeSpec -> ReadP Char -> ReadP TypeSpec
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 (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> ReadP Char
char Char
',' ReadP Char -> ReadP () -> ReadP Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadP ()
skipSpaces
pEllipsis :: ReadP String
pEllipsis :: ReadP String
pEllipsis = String -> ReadP String
string String
"..." ReadP String -> ReadP () -> ReadP String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadP ()
skipSpaces
anyType :: TypeSpec
anyType :: TypeSpec
anyType = TypeSpec
AnyType
voidType :: TypeSpec
voidType :: TypeSpec
voidType = [TypeSpec] -> TypeSpec
SumType []
booleanType :: TypeSpec
booleanType :: TypeSpec
booleanType = Type -> TypeSpec
BasicType Type
HsLua.TypeBoolean
functionType :: TypeSpec
functionType :: TypeSpec
functionType = Type -> TypeSpec
BasicType Type
HsLua.TypeFunction
lightUserdataType :: TypeSpec
lightUserdataType :: TypeSpec
lightUserdataType = Type -> TypeSpec
BasicType Type
HsLua.TypeLightUserdata
nilType :: TypeSpec
nilType :: TypeSpec
nilType = Type -> TypeSpec
BasicType Type
HsLua.TypeNil
numberType :: TypeSpec
numberType :: TypeSpec
numberType = Type -> TypeSpec
BasicType Type
HsLua.TypeNumber
stringType :: TypeSpec
stringType :: TypeSpec
stringType = Type -> TypeSpec
BasicType Type
HsLua.TypeString
tableType :: TypeSpec
tableType :: TypeSpec
tableType = Type -> TypeSpec
BasicType Type
HsLua.TypeTable
threadType :: TypeSpec
threadType :: TypeSpec
threadType = Type -> TypeSpec
BasicType Type
HsLua.TypeThread
userdataType :: TypeSpec
userdataType :: TypeSpec
userdataType = Type -> TypeSpec
BasicType Type
HsLua.TypeUserdata
integerType :: TypeSpec
integerType :: TypeSpec
integerType = Name -> TypeSpec
NamedType Name
"integer"
instance IsString TypeSpec where
fromString :: String -> TypeSpec
fromString = String -> TypeSpec
typeSpecFromString
seqType :: TypeSpec -> TypeSpec
seqType :: TypeSpec -> TypeSpec
seqType = TypeSpec -> TypeSpec
SeqType
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
pushTypeDoc :: LuaError e => Pusher e TypeDocs
pushTypeDoc :: Pusher e TypeDocs
pushTypeDoc TypeDocs
td = do
Int -> String -> LuaE e ()
forall e. LuaError e => Int -> String -> LuaE e ()
checkstack' Int
8 String
"HsLua.Typing.pushTypeDoc"
[(Name, Pusher e TypeDocs)] -> Pusher e TypeDocs
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) -> Pusher e TypeDocs
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) -> Pusher e TypeDocs
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) -> Pusher e TypeDocs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeDocs -> Maybe Name
typeRegistry)
] TypeDocs
td
peekTypeDoc :: LuaError e => Peeker e TypeDocs
peekTypeDoc :: 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 -> String -> LuaE e ()
forall e. LuaError e => Int -> String -> LuaE e ()
checkstack' Int
8 String
"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 (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
pushTypeSpec :: LuaError e
=> TypeSpec
-> LuaE e ()
pushTypeSpec :: TypeSpec -> LuaE e ()
pushTypeSpec TypeSpec
ts = do
Int -> String -> LuaE e ()
forall e. LuaError e => Int -> String -> LuaE e ()
checkstack' Int
8 String
"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", String -> LuaE e ()
forall e. String -> LuaE e ()
pushString (String -> LuaE e ()) -> (Type -> String) -> Type -> LuaE e ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> String
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)
String -> LuaE e ()
forall e. String -> LuaE e ()
pushString (String -> LuaE e ()) -> String -> LuaE e ()
forall a b. (a -> b) -> a -> b
$ TypeSpec -> String
typeSpecToString TypeSpec
ts'
NumResults -> HaskellFunction e
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)
basicTypeName :: Type -> String
basicTypeName :: Type -> String
basicTypeName = \case
Type
TypeLightUserdata -> String
"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 -> String
forall a. Show a => a -> String
show Type
t
peekTypeSpec :: LuaError e => Peeker e TypeSpec
peekTypeSpec :: 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 -> String -> LuaE e ()
forall e. LuaError e => Int -> String -> LuaE e ()
checkstack' Int
8 String
"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 (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 (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 (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 (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 (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 (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 (f :: * -> *) a. Applicative f => a -> f a
pure TypeSpec
AnyType)
] StackIndex
idx
where
peekBasicType :: StackIndex -> Peek e Type
peekBasicType StackIndex
idx = Peeker e String
forall e. Peeker e String
peekString StackIndex
idx Peek e String -> (String -> Peek e Type) -> Peek e Type
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
String
"light userdata" -> Type -> Peek e Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
TypeLightUserdata
(Char
c:String
cs) -> Peek e Type -> (Type -> Peek e Type) -> Maybe Type -> Peek e Type
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Peek e Type
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unknown type") Type -> Peek e Type
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
$
String -> Maybe Type
forall a. Read a => String -> Maybe a
readMaybe (String
"Type" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char -> Char
toUpper Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: String
cs)
String
_ -> ByteString -> Peek e Type
forall a e. ByteString -> Peek e a
failPeek ByteString
"invalid type string"