diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 diff --git a/hslua-typing.cabal b/hslua-typing.cabal new file mode 100644 --- /dev/null +++ b/hslua-typing.cabal @@ -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 +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 diff --git a/src/HsLua/Typing.hs b/src/HsLua/Typing.hs new file mode 100644 --- /dev/null +++ b/src/HsLua/Typing.hs @@ -0,0 +1,301 @@ +{-# 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" diff --git a/test/test-hslua-typing.hs b/test/test-hslua-typing.hs new file mode 100644 --- /dev/null +++ b/test/test-hslua-typing.hs @@ -0,0 +1,149 @@ +{-# 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