diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,3 +3,8 @@ ## 0.1.0 Initial release + +## 0.1.1 + +- Add `Arbitrary` instance for `I64` +- Documentation diff --git a/language-tl.cabal b/language-tl.cabal --- a/language-tl.cabal +++ b/language-tl.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 44e1133eb4597554897b9aa49a6ddfb4295b353328907c427d5e985ea47f941e +-- hash: e2914376a8e9f47240b73c2cc8d2f91d7ddb8f1db9bd4a058a6112c46a29e017 name: language-tl -version: 0.1.0 +version: 0.1.1 description: Please see the README on GitHub at homepage: https://github.com/poscat0x04/language-tl#readme bug-reports: https://github.com/poscat0x04/language-tl/issues @@ -40,7 +40,8 @@ src default-extensions: OverloadedStrings FlexibleInstances FlexibleContexts FunctionalDependencies InstanceSigs ConstraintKinds DeriveGeneric DeriveFunctor DeriveFoldable DeriveTraversable TypeOperators TypeApplications TypeFamilies KindSignatures PartialTypeSignatures DataKinds StarIsType ScopedTypeVariables ExplicitForAll ViewPatterns BangPatterns LambdaCase TupleSections EmptyCase MultiWayIf UnicodeSyntax PatternSynonyms RecordWildCards build-depends: - aeson >=1.4.7 && <1.5.2 + QuickCheck + , aeson >=1.4.7 && <1.5.2 , base >=4.10 && <5 , bytestring >=0.10.10.0 && <0.11 , containers >=0.6.2.1 && <0.7 @@ -60,7 +61,8 @@ default-extensions: OverloadedStrings FlexibleInstances FlexibleContexts FunctionalDependencies InstanceSigs ConstraintKinds DeriveGeneric DeriveFunctor DeriveFoldable DeriveTraversable TypeOperators TypeApplications TypeFamilies KindSignatures PartialTypeSignatures DataKinds StarIsType ScopedTypeVariables ExplicitForAll ViewPatterns BangPatterns LambdaCase TupleSections EmptyCase MultiWayIf UnicodeSyntax PatternSynonyms RecordWildCards ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: - aeson >=1.4.7 && <1.5.2 + QuickCheck + , aeson >=1.4.7 && <1.5.2 , base >=4.10 && <5 , bytestring >=0.10.10.0 && <0.11 , containers >=0.6.2.1 && <0.7 diff --git a/src/Language/TL/I64.hs b/src/Language/TL/I64.hs --- a/src/Language/TL/I64.hs +++ b/src/Language/TL/I64.hs @@ -8,9 +8,11 @@ import Data.Aeson import Data.Text (pack, unpack) +import Test.QuickCheck +-- | 64 bit integer that encodes to json strings instead of json reals newtype I64 = I64 {unI64 :: Int} - deriving newtype (Show, Read, Eq, Num, Ord, Real, Bounded) + deriving newtype (Show, Read, Eq, Num, Ord, Real, Bounded, Arbitrary) instance FromJSON I64 where parseJSON = diff --git a/src/Language/TL/Lexer.hs b/src/Language/TL/Lexer.hs --- a/src/Language/TL/Lexer.hs +++ b/src/Language/TL/Lexer.hs @@ -1,15 +1,42 @@ -module Language.TL.Lexer where +module Language.TL.Lexer + ( Parser, + -- * Helper functions + many, + many', + some, + optional, + lexeme, + sepBy1, + + -- * Tokenizing + string_, + char_, + between', + comment, + lcIdent', + ucIdent', + lcNsIdent, + ucNsIdent, + lcFullIdent, + emptyKw, + newKw, + finalKw, + nat, + ) +where + import Control.Applicative (liftA2) import Data.Char import Data.List.NonEmpty (NonEmpty (..)) import Data.Text (Text, cons) import Data.Void import Language.TL.Types -import Text.Megaparsec hiding (many, optional, sepBy1) +import Text.Megaparsec hiding (many, optional, sepBy1, some) import Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer as L +-- | Parser type type Parser = Parsec Void Text -- | remove whitespaces @@ -20,50 +47,51 @@ (L.skipLineComment "//") (L.skipBlockComment "/*" "*/") -sc' :: Parser () -sc' = - L.space - space1 - empty - empty - +-- | 'many'' but removes whitespaces and comments before parsing each segment many :: Parser a -> Parser [a] many = many' . lexeme +-- | @some@ that backtracks and removes whitespaces etc. some :: Parser a -> Parser (NonEmpty a) some p = (:|) <$> p <*> many p +-- | @many@ that backtracks many' :: Parser a -> Parser [a] many' v = many_v where many_v = try some_v <|> pure [] some_v = liftA2 (:) v many_v +-- | 'optional'' but removes whitespaces etc. optional :: Parser a -> Parser (Maybe a) optional = optional' . lexeme +-- | @optional@ that backtracks optional' :: Parser a -> Parser (Maybe a) optional' v = Just <$> try v <|> pure Nothing +-- | Removes whitespaces and comments before parsing lexeme :: Parser a -> Parser a lexeme = (sc >>) -lexeme' :: Parser a -> Parser a -lexeme' = (sc' >>) - +-- | String lexeme string_ :: Text -> Parser Text string_ = lexeme . string +-- | Character lexeme char_ :: Char -> Parser Char char_ = lexeme . char +-- | 'between' but removes whitespaces etc. between' :: Parser open -> Parser close -> Parser a -> Parser a between' o c p = between o (lexeme c) (lexeme p) +-- | take til line end tilLineEnd :: Parser Text tilLineEnd = takeWhileP (Just "Line content") (/= '\n') +-- | parses block comment blockComment :: Parser Text blockComment = do string "/*" @@ -78,11 +106,13 @@ pure (cons ch bc) pure (c <> c') +-- | Parses line comment lineComment :: Parser Text lineComment = do string "//" tilLineEnd +-- | Parses a comment block comment :: Parser Comment comment = bc <|> lc where @@ -98,6 +128,7 @@ t <- takeWhileP (Just "ident-char") identChar pure $ cons h t +-- | Parses a lower case identfier lcIdent' :: Parser Ident lcIdent' = do ident <- lcIdent @@ -109,6 +140,7 @@ t <- takeWhileP (Just "ident-char") identChar pure $ cons h t +-- | Parses a upper case identifier ucIdent' :: Parser Ident ucIdent' = do ident <- ucIdent @@ -117,6 +149,7 @@ nsIdent :: Parser Text nsIdent = lcIdent +-- | Parses a lower case potentially qualified identifier lcNsIdent :: Parser Ident lcNsIdent = try unqualified <|> qualified where @@ -130,6 +163,7 @@ ident <- lcIdent pure Unqualified {..} +-- | Parses a upper case potentially qualified identifier ucNsIdent :: Parser Ident ucNsIdent = try unqualified <|> qualified where @@ -143,6 +177,7 @@ ident <- ucIdent pure Unqualified {..} +-- | Parses a lower case full identifier lcFullIdent :: Parser FullIdent lcFullIdent = do ident <- lcNsIdent @@ -151,23 +186,28 @@ L.hexadecimal pure $ FullName ident name +-- | Consumes keyword @Final@ finalKw :: Parser () finalKw = do string "Final" pure () +-- | Consumes keyword @New@ newKw :: Parser () newKw = do string "New" pure () +-- | Consumes keyword @Empty@ emptyKw :: Parser () emptyKw = do string "Empty" pure () +-- | Parses a natural number nat :: Parser Int nat = L.decimal +-- | @sepBy1@ that backtracks and removes whitespaces etc. sepBy1 :: Parser a -> Parser sep -> Parser (NonEmpty a) sepBy1 p sep = liftA2 (:|) p (many (lexeme sep *> lexeme p)) diff --git a/src/Language/TL/Parser.hs b/src/Language/TL/Parser.hs --- a/src/Language/TL/Parser.hs +++ b/src/Language/TL/Parser.hs @@ -49,9 +49,6 @@ papp = PartialApp <$> partialAppDecl final = FinalDecl <$> finalDecl --- >>> parseTest decl "vector {t:Type} # [ t ] = Vector t;" --- Combinator (CombinatorDecl {combId = Optional (FullName (Unqualified {casing = L, ident = "vector"}) Nothing), optArglist = [OptArgs (Unqualified {casing = L, ident = "t"} :| []) False (Exprs {subexprs = [Sum (Right (Type (Boxed (Unqualified {casing = U, ident = "Type"}))) :| [])]})], argsList = [Unnamed False (Type NatType),MultipleArgs Nothing Nothing [Unnamed False (Type (LcIdent (Unqualified {casing = L, ident = "t"})))]], resType = RTypeApp (Unqualified {casing = U, ident = "Vector"}) [Sum (Right (Type (LcIdent (Unqualified {casing = L, ident = "t"}))) :| [])]}) --- ---------- typeExpr :: Parser Expr diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,12 +1,12 @@ module Main where -import qualified Data.Text.IO as T -import Language.TL.Parser -import Language.TL.Types -import Text.Megaparsec +import Data.Aeson +import Language.TL.I64 +import Test.QuickCheck main :: IO () main = do - f <- T.readFile "test/data/td_api.tl" - let Right res = runParser program "td_api.tl" f - print $ head res + quickCheck bijection + +bijection :: I64 -> Property +bijection i = decode (encode i) === Just i