hslua-typing (empty) → 0.1.0
raw patch · 6 files changed
+577/−0 lines, 6 filesdep +QuickCheckdep +basedep +containers
Dependencies added: QuickCheck, base, containers, hslua-core, hslua-marshalling, hslua-typing, lua-arbitrary, quickcheck-instances, tasty, tasty-hunit, tasty-quickcheck, text
Files
- CHANGELOG.md +11/−0
- LICENSE +19/−0
- README.md +19/−0
- hslua-typing.cabal +78/−0
- src/HsLua/Typing.hs +301/−0
- test/test-hslua-typing.hs +149/−0
+ CHANGELOG.md view
@@ -0,0 +1,11 @@+# Changelog++`hslua-typing` uses [PVP Versioning][].++## hslua-typing-0.1.0++Released 2023-03-13.++- Released into the wild. May it live long and prosper.++ [PVP Versioning]: https://pvp.haskell.org
+ LICENSE view
@@ -0,0 +1,19 @@+Copyright © 2023 Albert Krewinkel++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ README.md view
@@ -0,0 +1,19 @@+hslua-typing+==============++[![MIT License]](./LICENSE)++Type specifiers for Lua.++Structure to hold detailed type information. The primary use-case+at this time are auto-generated docs.+++License+-------++This project is licensed under the MIT license, the same license+under which Lua and all other HsLua packages are published. See the+[LICENSE](./LICENSE) file for details.++[MIT License]: https://img.shields.io/github/license/hslua/hslua-aeson.svg?style=flat-square
+ hslua-typing.cabal view
@@ -0,0 +1,78 @@+cabal-version: 2.2+name: hslua-typing+version: 0.1.0+synopsis: Type specifiers for Lua.+description: Structure to hold detailed type information. The primary+ use-case at this time are auto-generated docs.+homepage: https://hslua.org/+license: MIT+license-file: LICENSE+author: Albert Krewinkel+maintainer: Albert Krewinkel <tarleb@hslua.org>+copyright: © 2023 Albert Krewinkel+category: Foreign+extra-source-files: README.md+ , CHANGELOG.md+tested-with: GHC == 8.4.4+ , GHC == 8.6.5+ , GHC == 8.8.4+ , GHC == 8.10.7+ , GHC == 9.0.2+ , GHC == 9.2.5+ , GHC == 9.4.4++source-repository head+ type: git+ location: https://github.com/hslua/hslua+ subdir: hslua-typing++common common-options+ default-language: Haskell2010+ build-depends: base >= 4.11 && < 5+ other-extensions: DeriveGeneric+ , LambdaCase+ , OverloadedStrings+ ghc-options: -Wall -fno-warn-unused-do-bind+ -Wcpp-undef+ -Widentities+ -Wincomplete-record-updates+ -Wincomplete-uni-patterns+ -Wmissing-export-lists+ -Wmissing-signatures+ -Wnoncanonical-monad-instances+ -Wpartial-fields+ -Wredundant-constraints+ -fhide-source-paths++ if impl(ghc >= 8.10)+ ghc-options: -Wunused-packages++ if impl(ghc >= 9.0)+ ghc-options: -Winvalid-haddock++library+ import: common-options+ exposed-modules: HsLua.Typing+ hs-source-dirs: src+ build-depends: containers >= 0.5.9 && < 0.7+ , hslua-core >= 2.3 && < 2.4+ , hslua-marshalling >= 2.3 && < 2.4+ , text >= 1.2 && < 2.1+ default-language: Haskell2010++test-suite test-hslua-typing+ import: common-options+ type: exitcode-stdio-1.0+ main-is: test-hslua-typing.hs+ hs-source-dirs: test+ build-depends: hslua-typing+ , QuickCheck+ , hslua-core+ , hslua-marshalling+ , lua-arbitrary >= 1.0 && < 1.1+ , quickcheck-instances+ , tasty >= 0.11+ , tasty-hunit >= 0.10+ , tasty-quickcheck >= 0.8+ ghc-options: -threaded+ default-language: Haskell2010
+ src/HsLua/Typing.hs view
@@ -0,0 +1,301 @@+{-# 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 (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"
+ test/test-hslua-typing.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-|+Module : Main+Copyright : © 2023 Albert Krewinkel+License : MIT+Maintainer : Albert Krewinkel <tarleb@hslua.org>++Tests for type specifiers.+-}+import Control.Monad (when)+import Data.String (fromString)+import HsLua.Core+import HsLua.Core.Types+import HsLua.Marshalling+import HsLua.Typing+import Lua.Arbitrary ()+import Test.Tasty (TestTree, defaultMain, testGroup)+import Test.Tasty.HUnit ((@?=), testCase)+import Test.Tasty.QuickCheck+import Test.QuickCheck.Instances ()+import qualified HsLua.Core as HsLua+import qualified Test.QuickCheck.Monadic as QC++-- | Run this spec.+main :: IO ()+main = defaultMain tests++-- | Aeson tests+tests :: TestTree+tests = testGroup "hslua-typespec"+ [ testGroup "string representation"+ [ testCase "any" $ "any" @?= anyType+ , testCase "boolean" $ "boolean" @?= booleanType+ , testCase "function" $ "function" @?= functionType+ , testCase "integer" $ "integer" @?= integerType+ , testCase "nil" $ "nil" @?= nilType+ , testCase "number" $ "number" @?= numberType+ , testCase "string" $ "string" @?= stringType+ , testCase "table" $ "table" @?= tableType+ , testCase "userdata" $ "userdata" @?= userdataType+ , testCase "light userdata" $+ "light userdata" @?= lightUserdataType+ , testCase "sequence" $+ "{string,...}" @?= seqType stringType+ , testCase "alternative" $+ "string|boolean|number" @?= stringType #|# (booleanType #|# numberType)+ , testCase "sequence of alternatives" $+ "{string|number,...}" @?=+ seqType (stringType #|# numberType)+ , testCase "string or strings" $+ "string|{string,...}" @?=+ stringType #|# seqType stringType+ , testCase "strings or string" $+ "{string,...}|string" @?=+ seqType stringType #|# stringType+ , testCase "sequence of sequences" $+ "{{number,...}, ... }" @?=+ seqType (seqType "number")+ ]++ , testGroup "to string"+ [ testCase "any" $ typeSpecToString anyType @?= "any"+ , testCase "boolean" $ typeSpecToString booleanType @?= "boolean"+ , testCase "function" $ typeSpecToString functionType @?= "function"+ , testCase "number" $ typeSpecToString numberType @?= "number"+ , testCase "string" $ typeSpecToString stringType @?= "string"+ , testCase "table" $ typeSpecToString tableType @?= "table"+ , testCase "userdata" $ typeSpecToString userdataType @?= "userdata"+ , testCase "sequence" $+ seqType stringType @?= "{string,...}"+ ]++ , testGroup "operators"+ [ testGroup "#|#"+ -- These should be property tests+ [ testCase "combining basic types yields sum type" $+ booleanType #|# numberType @?= SumType [booleanType, numberType]+ , testCase "any is the unit" $ do+ booleanType #|# anyType @?= anyType+ anyType #|# booleanType @?= anyType+ , testCase "void is zero" $ do+ booleanType #|# voidType @?= booleanType+ voidType #|# numberType @?= numberType+ ]+ ]++ , testGroup "Marshalling"+ [ testProperty "Roundtrip TypeSpec" $+ assertRoundtripEqual pushTypeSpec peekTypeSpec++ , testProperty "Roundtrip TypeDocs" $+ assertRoundtripEqual pushTypeDoc peekTypeDoc+ ]+ ]++instance Arbitrary TypeSpec where+ arbitrary = arbitraryTypeSpec 3+ shrink = shrinkTypeSpec++instance Arbitrary TypeDocs where+ arbitrary = TypeDocs+ <$> arbitrary+ <*> arbitrary+ <*> arbitrary+ shrink td = (\ts -> td{ typeSpec = ts}) <$> shrink (typeSpec td)++instance Arbitrary Name where+ arbitrary = Name . fromString <$> arbitrary++arbitraryTypeSpec :: Int -> Gen TypeSpec+arbitraryTypeSpec size = frequency+ [ (8, BasicType . toType <$> arbitrary)+ , (1, NamedType <$> arbitrary)+ , (3, resize (size - 1) $ SeqType <$> arbitrary)+ , (2, resize (size - 1) $ SumType <$> arbitrary)+ , (2, resize (size - 1) $ RecType <$> arbitrary)+ , (1, resize (size - 1) $ FunType <$> arbitrary <*> arbitrary)+ , (1, return AnyType)+ ]++shrinkTypeSpec :: TypeSpec -> [TypeSpec]+shrinkTypeSpec = \case+ SumType cs -> SumType <$> shrinkList shrink cs+ SeqType x -> shrink x+ FunType d c -> (FunType c <$> shrinkList shrinkTypeSpec d) +++ ((`FunType` d) <$> shrinkList shrinkTypeSpec c)+ x -> shrinkNothing x+++assertRoundtripEqual :: Eq a+ => Pusher HsLua.Exception a -> Peeker HsLua.Exception a+ -> a -> Property+assertRoundtripEqual pushX peekX x = QC.monadicIO $ do+ y <- QC.run $ roundtrip pushX peekX x+ QC.assert (x == y)++roundtrip :: Pusher HsLua.Exception a -> Peeker HsLua.Exception a -> a -> IO a+roundtrip pushX peekX x = run $ do+ pushX x+ size <- gettop+ when (size /= 1) $+ failLua $ "not the right amount of elements on the stack: " ++ show size+ result <- forcePeek $ peekX top+ afterPeekSize <- gettop+ when (afterPeekSize /= 1) $+ failLua $ "peeking modified the stack: " ++ show afterPeekSize+ return result