hslua-typing-0.1.0/0000755000000000000000000000000007346545000012325 5ustar0000000000000000hslua-typing-0.1.0/CHANGELOG.md0000644000000000000000000000031207346545000014132 0ustar0000000000000000# 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 hslua-typing-0.1.0/LICENSE0000644000000000000000000000204407346545000013332 0ustar0000000000000000Copyright © 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. hslua-typing-0.1.0/README.md0000644000000000000000000000073107346545000013605 0ustar0000000000000000hslua-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-0.1.0/hslua-typing.cabal0000644000000000000000000000552407346545000015743 0ustar0000000000000000cabal-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 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 hslua-typing-0.1.0/src/HsLua/0000755000000000000000000000000007346545000014130 5ustar0000000000000000hslua-typing-0.1.0/src/HsLua/Typing.hs0000644000000000000000000002260307346545000015741 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-| Module : HsLua.Typing Copyright : © 2023 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel 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" hslua-typing-0.1.0/test/0000755000000000000000000000000007346545000013304 5ustar0000000000000000hslua-typing-0.1.0/test/test-hslua-typing.hs0000644000000000000000000001175307346545000017250 0ustar0000000000000000{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-| Module : Main Copyright : © 2023 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel 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