From e4e73e77f5a6fbc4e7f7d7cc9e9d2f723413b654 Mon Sep 17 00:00:00 2001 From: drlkf Date: Fri, 28 Aug 2026 22:39:20 +0200 Subject: [PATCH 1/3] chore: update to ghc 9.10 --- .github/workflows/stack-build.yml | 4 ++-- package.yaml | 2 +- stack.yaml | 2 +- stack.yaml.lock | 8 ++++---- 4 files changed, 8 insertions(+), 8 deletions(-) diff --git a/.github/workflows/stack-build.yml b/.github/workflows/stack-build.yml index 60055f4..9871f5f 100644 --- a/.github/workflows/stack-build.yml +++ b/.github/workflows/stack-build.yml @@ -18,8 +18,8 @@ jobs: matrix: os: [ubuntu] stack: - - lts: &default-lts 21.25 - ghc: &default-ghc 9.4.8 + - lts: &default-lts 24.56 + ghc: &default-ghc 9.10.3 - lts: 22.44 ghc: 9.6.7 diff --git a/package.yaml b/package.yaml index 1ff7045..2a4227c 100644 --- a/package.yaml +++ b/package.yaml @@ -11,9 +11,9 @@ homepage: https://github.com/haskell-github-trust/megaparsec-utils bug-reports: https://github.com/haskell-github-trust/megaparsec-utils/issues category: Parsing tested-with: + - GHC == 9.10 - GHC == 9.8 - GHC == 9.6 - - GHC == 9.4 extra-source-files: - README.md diff --git a/stack.yaml b/stack.yaml index e859074..6aee391 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,5 +1,5 @@ --- -resolver: lts-21.25 +resolver: lts-24.56 packages: - . ... diff --git a/stack.yaml.lock b/stack.yaml.lock index ffcc1f2..a7a5ca1 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -6,7 +6,7 @@ packages: [] snapshots: - completed: - sha256: a81fb3877c4f9031e1325eb3935122e608d80715dc16b586eb11ddbff8671ecd - size: 640086 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/25.yaml - original: lts-21.25 + sha256: 121a2b65e6842f67819409330694d068e6276f64df87faaf2a66c0016ddf277b + size: 732456 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/24/56.yaml + original: lts-24.56 From cbb1e7992897d6e5a8299e88966978e8a7af7c85 Mon Sep 17 00:00:00 2001 From: drlkf Date: Fri, 28 Aug 2026 23:23:33 +0200 Subject: [PATCH 2/3] feat: add bytestring support --- package.yaml | 1 + src/Text/Megaparsec/Utils.hs | 71 ++-------- src/Text/Megaparsec/Utils/Byte.hs | 120 +++++++++++++++++ src/Text/Megaparsec/Utils/Char.hs | 111 ++++++++++++++++ src/Text/Megaparsec/Utils/Common.hs | 164 ++++++++++++++++++++++++ test/Text/Megaparsec/UtilsStreamSpec.hs | 66 ++++++++++ 6 files changed, 476 insertions(+), 57 deletions(-) create mode 100644 src/Text/Megaparsec/Utils/Byte.hs create mode 100644 src/Text/Megaparsec/Utils/Char.hs create mode 100644 src/Text/Megaparsec/Utils/Common.hs create mode 100644 test/Text/Megaparsec/UtilsStreamSpec.hs diff --git a/package.yaml b/package.yaml index 2a4227c..e1b516f 100644 --- a/package.yaml +++ b/package.yaml @@ -25,6 +25,7 @@ description: | dependencies: - base >= 4.7 && < 5 - aeson >= 2.0 && < 3 + - bytestring >= 0.11 && < 0.13 - megaparsec >= 9.0 && < 10 - parser-combinators >= 1.0 && < 2 - text >= 2.0 && < 3 diff --git a/src/Text/Megaparsec/Utils.hs b/src/Text/Megaparsec/Utils.hs index 0e2f8a5..bbb4acc 100644 --- a/src/Text/Megaparsec/Utils.hs +++ b/src/Text/Megaparsec/Utils.hs @@ -10,7 +10,8 @@ -- Maintainer : drlkf@drlkf.net -- Stability : experimental -- --- Generic utilities and common parsers. +-- String-based shims over 'Text.Megaparsec.Utils.Char'. New code should use +-- 'Text.Megaparsec.Utils.Char' or 'Text.Megaparsec.Utils.Byte' directly. module Text.Megaparsec.Utils ( -- * Scalar parsers boolParser, @@ -30,43 +31,25 @@ module Text.Megaparsec.Utils ( parsecToJSONParser, ) where -import Control.Applicative (many, some, (<|>)) -import Control.Applicative.Combinators (choice) -import Control.Monad (replicateM) -import Control.Monad.Combinators (optional) import Data.Aeson.Types (Parser, Value, withText) -import Data.Functor (($>)) -import Data.List (intercalate, sortOn) -import Data.List.NonEmpty (NonEmpty ((:|))) -import Data.Maybe (fromJust) +import Data.List.NonEmpty (NonEmpty) import qualified Data.Text as T (unpack) import Data.UUID (UUID) -import qualified Data.UUID as U (fromString) import Text.Megaparsec ( Parsec, ShowErrorComponent, - anySingle, errorBundlePretty, runParser, - try, ) -import Text.Megaparsec.Char ( - char, - digitChar, - hexDigitChar, - string', - ) -import Text.Read (readMaybe) +import qualified Text.Megaparsec.Utils.Char as Char +import qualified Text.Megaparsec.Utils.Common as Common -- | Parse a case-insensitive human-readable boolean, including C-style numbers, -- English yes-no and @on@ / @off@. boolParser :: Ord e => Parsec e String Bool -boolParser = true <|> false - where - true = True <$ choice (map string' ["true", "y", "yes", "on", "1"]) - false = False <$ choice (map string' ["false", "n", "no", "off", "0"]) +boolParser = Char.boolParser -- | Parse a 'Bounded' 'Enum' type that has a 'Show' instance, trying all -- possibilities, case-insensitive, in the 'Enum' order. @@ -77,58 +60,42 @@ boundedEnumShowParser => Enum a => Show a => Parsec e String a -boundedEnumShowParser = - choice . map parseShow $ sortOn (negate . length . show) [(minBound :: a) ..] - where - parseShow a = string' (show a) $> a +boundedEnumShowParser = Char.boundedEnumShowParser -- | Parse a comma-separated list of items. commaSeparated :: Ord e => Parsec e String a -> Parsec e String (NonEmpty a) -commaSeparated p = (:|) <$> p <*> many (char ',' >> p) +commaSeparated = Char.commaSeparated -- | Parse any occurrence of a given parser. Consumes any input before occurrence. occurrence :: Ord e => Parsec e String a -> Parsec e String a -occurrence p = go - where - go = p <|> (anySingle >> go) +occurrence = Common.occurrence -- | Parse all occurrences of a given parser. occurrences :: Ord e => Parsec e String a -> Parsec e String [a] -occurrences = some . try . occurrence . try +occurrences = Common.occurrences -- | Parse a positive number, with or without decimals prefixed by a @.@. posDecNumParser :: Ord e => Read a => Parsec e String a -posDecNumParser = do - num <- some digitChar - dec <- maybe "" ("." <>) <$> optional (char '.' >> some digitChar) - - let str = num <> dec - - maybe (fail ("could not read from input: " <> str)) pure (readMaybe str) +posDecNumParser = Char.posDecNumParser -- | Parse a positive integer. posNumParser :: Ord e => Read a => Parsec e String a -posNumParser = do - digits <- some digitChar - maybe - (fail ("could not read from digits: " <> digits)) - pure - (readMaybe digits) +posNumParser = Char.posNumParser -- | Parse an integer, without any space between minus sign and digits. numParser @@ -136,7 +103,7 @@ numParser => Num a => Read a => Parsec e String a -numParser = (char '-' >> negate <$> posNumParser) <|> posNumParser +numParser = Char.numParser -- | Convert a 'Parsec' parser into a 'Parser' suited for 'Data.Aeson.FromJSON' -- instances. @@ -161,14 +128,4 @@ parsecToReadsPrec p = either (const []) (\x -> [(x, "")]) . runParser p "string" uuidParser :: Ord e => Parsec e String UUID -uuidParser = do - part1 <- replicateM 8 hexDigitChar <* char '-' - part2 <- replicateM 4 hexDigitChar <* char '-' - part3 <- replicateM 4 hexDigitChar <* char '-' - part4 <- replicateM 4 hexDigitChar <* char '-' - part5 <- replicateM 12 hexDigitChar - - pure - (fromJust - (U.fromString - (intercalate "-" [part1, part2, part3, part4, part5]))) +uuidParser = Char.uuidParser diff --git a/src/Text/Megaparsec/Utils/Byte.hs b/src/Text/Megaparsec/Utils/Byte.hs new file mode 100644 index 0000000..7333ef1 --- /dev/null +++ b/src/Text/Megaparsec/Utils/Byte.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +-- | +-- Module : Text.Megaparsec.Utils.Byte +-- Description : Parsers for streams of 'Word8'. +-- Copyright : (c) drlkf, 2026 +-- License : GPL-3 +-- Maintainer : drlkf@drlkf.net +-- Stability : experimental +-- +-- Generic parsers for streams of 'Word8' (strict and lazy 'ByteString'). +module Text.Megaparsec.Utils.Byte ( + -- * Scalar parsers + boolParser, + numParser, + posDecNumParser, + posNumParser, + uuidParser, + + -- * Combinators + commaSeparated, + + -- * Compatibility utilities + boundedEnumShowParser, +) where + +import Data.List.NonEmpty (NonEmpty) +import Data.UUID (UUID) +import Data.Word (Word8) +import Text.Megaparsec (MonadParsec, Token) +import Text.Megaparsec.Byte (char, char', digitChar, hexDigitChar) +import Text.Megaparsec.Utils.Common ( + mkBoolParser, + mkBoundedEnumShowParser, + mkCommaSeparated, + mkNumParser, + mkPosDecNumParser, + mkPosNumParser, + mkUuidParser, + ) + +-- | Parse a case-insensitive human-readable boolean, including C-style numbers, +-- English yes-no and @on@ / @off@. +-- +-- @since UNRELEASED@ +boolParser + :: MonadParsec e s m + => Token s ~ Word8 + => m Bool +boolParser = mkBoolParser char' (toEnum . fromEnum) + +-- | Parse a 'Bounded' 'Enum' type that has a 'Show' instance, trying all +-- possibilities, case-insensitive, in the 'Enum' order. +-- +-- @since UNRELEASED@ +boundedEnumShowParser + :: forall a e s m + . MonadParsec e s m + => Token s ~ Word8 + => Bounded a + => Enum a + => Show a + => m a +boundedEnumShowParser = mkBoundedEnumShowParser char' (toEnum . fromEnum) + +-- | Parse a comma-separated list of items. +-- +-- @since UNRELEASED@ +commaSeparated + :: MonadParsec e s m + => Token s ~ Word8 + => m a + -> m (NonEmpty a) +commaSeparated = mkCommaSeparated (char 44) + +-- | Parse a positive number, with or without decimals prefixed by a @.@. +-- +-- @since UNRELEASED@ +posDecNumParser + :: MonadFail m + => MonadParsec e s m + => Read a + => Token s ~ Word8 + => m a +posDecNumParser = mkPosDecNumParser digitChar (char 46) (toEnum . fromIntegral) + +-- | Parse a positive integer. +-- +-- @since UNRELEASED@ +posNumParser + :: MonadFail m + => MonadParsec e s m + => Read a + => Token s ~ Word8 + => m a +posNumParser = mkPosNumParser digitChar (toEnum . fromIntegral) + +-- | Parse an integer, without any space between minus sign and digits. +-- +-- @since UNRELEASED@ +numParser + :: MonadFail m + => MonadParsec e s m + => Num a + => Read a + => Token s ~ Word8 + => m a +numParser = mkNumParser (char 45) posNumParser + +-- | Parse a RFC4122-compliant UUID. +-- +-- @since UNRELEASED@ +uuidParser + :: MonadParsec e s m + => Token s ~ Word8 + => m UUID +uuidParser = mkUuidParser hexDigitChar (char 45) (toEnum . fromIntegral) diff --git a/src/Text/Megaparsec/Utils/Char.hs b/src/Text/Megaparsec/Utils/Char.hs new file mode 100644 index 0000000..84a08ce --- /dev/null +++ b/src/Text/Megaparsec/Utils/Char.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +-- | +-- Module : Text.Megaparsec.Utils.Char +-- Description : Parsers for streams of 'Char'. +-- Copyright : (c) drlkf, 2024 +-- License : GPL-3 +-- Maintainer : drlkf@drlkf.net +-- Stability : experimental +-- +-- Generic parsers for streams of 'Char' ('String', 'Text', lazy 'Text'). +module Text.Megaparsec.Utils.Char ( + -- * Scalar parsers + boolParser, + numParser, + posDecNumParser, + posNumParser, + uuidParser, + + -- * Combinators + commaSeparated, + + -- * Compatibility utilities + boundedEnumShowParser, + parsecToJSONParser, +) where + +import Data.Aeson.Types (Parser, Value, withText) +import Data.List.NonEmpty (NonEmpty) +import Data.Text (Text) +import Data.UUID (UUID) +import Text.Megaparsec ( + MonadParsec, + Parsec, + ShowErrorComponent, + Token, + errorBundlePretty, + runParser, + ) +import Text.Megaparsec.Char (char, char', digitChar, hexDigitChar) +import Text.Megaparsec.Utils.Common ( + mkBoolParser, + mkBoundedEnumShowParser, + mkCommaSeparated, + mkNumParser, + mkPosDecNumParser, + mkPosNumParser, + mkUuidParser, + ) + +-- | Parse a case-insensitive human-readable boolean, including C-style numbers, +-- English yes-no and @on@ / @off@. +boolParser :: (MonadParsec e s m, Token s ~ Char) => m Bool +boolParser = mkBoolParser char' id + +-- | Parse a 'Bounded' 'Enum' type that has a 'Show' instance, trying all +-- possibilities, case-insensitive, in the 'Enum' order. +boundedEnumShowParser + :: forall a e s m + . (MonadParsec e s m, Token s ~ Char) + => Bounded a + => Enum a + => Show a + => m a +boundedEnumShowParser = mkBoundedEnumShowParser char' id + +-- | Parse a comma-separated list of items. +commaSeparated + :: (MonadParsec e s m, Token s ~ Char) + => m a + -> m (NonEmpty a) +commaSeparated = mkCommaSeparated (char ',') + +-- | Parse a positive number, with or without decimals prefixed by a @.@. +posDecNumParser + :: (MonadFail m, MonadParsec e s m, Read a, Token s ~ Char) + => m a +posDecNumParser = mkPosDecNumParser digitChar (char '.') id + +-- | Parse a positive integer. +posNumParser + :: (MonadFail m, MonadParsec e s m, Read a, Token s ~ Char) + => m a +posNumParser = mkPosNumParser digitChar id + +-- | Parse an integer, without any space between minus sign and digits. +numParser + :: (MonadFail m, MonadParsec e s m, Num a, Read a, Token s ~ Char) + => m a +numParser = mkNumParser (char '-') posNumParser + +-- | Convert a 'Parsec' parser on 'Text' into a 'Parser' suited for +-- 'Data.Aeson.FromJSON' instances. +parsecToJSONParser + :: ShowErrorComponent e + => String + -- ^ Parser name. + -> Parsec e Text a + -- ^ Parser. + -> (Value -> Parser a) +parsecToJSONParser n p = + withText n (either (fail . errorBundlePretty) pure . runParser p n) + +-- | Parse a RFC4122-compliant UUID. +uuidParser + :: (MonadParsec e s m, Token s ~ Char) + => m UUID +uuidParser = mkUuidParser hexDigitChar (char '-') id \ No newline at end of file diff --git a/src/Text/Megaparsec/Utils/Common.hs b/src/Text/Megaparsec/Utils/Common.hs new file mode 100644 index 0000000..b752ae3 --- /dev/null +++ b/src/Text/Megaparsec/Utils/Common.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Text.Megaparsec.Utils.Common +-- Description : Stream-agnostic combinators. +-- Copyright : (c) drlkf, 2024 +-- License : GPL-3 +-- Maintainer : drlkf@drlkf.net +-- Stability : experimental +-- +-- Combinators that work on any stream. +module Text.Megaparsec.Utils.Common ( + occurrence, + occurrences, + + -- * Shared parser builders + mkBoolParser, + mkBoundedEnumShowParser, + mkCommaSeparated, + mkNumParser, + mkPosDecNumParser, + mkPosNumParser, + mkUuidParser, +) where + +import Control.Applicative (many, some, (<|>)) +import Control.Applicative.Combinators (choice) +import Control.Monad (replicateM) +import Control.Monad.Combinators (optional) +import Data.Foldable (traverse_) +import Data.Functor (($>)) +import Data.List (intercalate, sortOn) +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Maybe (fromJust) +import Data.UUID (UUID) +import qualified Data.UUID as U (fromString) +import Text.Megaparsec (MonadParsec, Token, anySingle, try) +import Text.Read (readMaybe) + +-- | Parse any occurrence of a given parser. Consumes any input before occurrence. +occurrence :: MonadParsec e s m => m a -> m a +occurrence p = go + where + go = p <|> (anySingle >> go) + +-- | Parse all occurrences of a given parser. +occurrences :: MonadParsec e s m => m a -> m [a] +occurrences = some . try . occurrence . try + +-- | Build a case-insensitive human-readable boolean parser, including C-style +-- numbers, English yes-no and @on@ / @off@. +mkBoolParser + :: MonadParsec e s m + => (Token s -> m (Token s)) + -- ^ Case-insensitive single-token parser. + -> (Char -> Token s) + -- ^ Convert a literal 'Char' to a token. + -> m Bool +mkBoolParser char' fromChar = true <|> false + where + true = True <$ choice (map (try . traverse_ (char' . fromChar)) ["true", "y", "yes", "on", "1"]) + false = False <$ choice (map (try . traverse_ (char' . fromChar)) ["false", "n", "no", "off", "0"]) + +-- | Build a parser for a 'Bounded' 'Enum' type that has a 'Show' instance, +-- trying all possibilities, case-insensitive, in the 'Enum' order. +mkBoundedEnumShowParser + :: forall a e s m + . (MonadParsec e s m) + => Bounded a + => Enum a + => Show a + => (Token s -> m (Token s)) + -- ^ Case-insensitive single-token parser. + -> (Char -> Token s) + -- ^ Convert a literal 'Char' to a token. + -> m a +mkBoundedEnumShowParser char' fromChar = + choice . map parseShow $ sortOn (negate . length . show) [(minBound :: a) ..] + where + parseShow a = try (traverse_ (char' . fromChar) (show a)) $> a + +-- | Build a parser for a comma-separated list of items. +mkCommaSeparated + :: MonadParsec e s m + => m (Token s) + -- ^ Comma parser. + -> m a + -> m (NonEmpty a) +mkCommaSeparated comma p = (:|) <$> p <*> many (comma >> p) + +-- | Build a parser for a positive number, with or without decimals prefixed by +-- a @.@. +mkPosDecNumParser + :: (MonadFail m, MonadParsec e s m, Read a) + => m (Token s) + -- ^ Digit parser. + -> m (Token s) + -- ^ Decimal-point parser. + -> (Token s -> Char) + -- ^ Convert a token to a 'Char'. + -> m a +mkPosDecNumParser digitChar dot toChar = do + num <- some digitChar + dec <- optional (dot >> some digitChar) + + let toStr = map toChar + str = toStr num <> maybe "" (('.' :) . toStr) dec + + maybe (fail ("could not read from input: " <> str)) pure (readMaybe str) + +-- | Build a parser for a positive integer. +mkPosNumParser + :: (MonadFail m, MonadParsec e s m, Read a) + => m (Token s) + -- ^ Digit parser. + -> (Token s -> Char) + -- ^ Convert a token to a 'Char'. + -> m a +mkPosNumParser digitChar toChar = do + digits <- some digitChar + let str = map toChar digits + maybe + (fail ("could not read from digits: " <> str)) + pure + (readMaybe str) + +-- | Build a parser for an integer, without any space between minus sign and +-- digits. +mkNumParser + :: (MonadFail m, MonadParsec e s m, Num a, Read a) + => m (Token s) + -- ^ Minus-sign parser. + -> m a + -- ^ Positive-number parser. + -> m a +mkNumParser minus posNumParser = (minus >> negate <$> posNumParser) <|> posNumParser + +-- | Build a parser for a RFC4122-compliant UUID. +mkUuidParser + :: MonadParsec e s m + => m (Token s) + -- ^ Hex-digit parser. + -> m (Token s) + -- ^ Dash parser. + -> (Token s -> Char) + -- ^ Convert a token to a 'Char'. + -> m UUID +mkUuidParser hexDigitChar dash toChar = do + part1 <- replicateM 8 hexDigitChar <* dash + part2 <- replicateM 4 hexDigitChar <* dash + part3 <- replicateM 4 hexDigitChar <* dash + part4 <- replicateM 4 hexDigitChar <* dash + part5 <- replicateM 12 hexDigitChar + + let toStr = map toChar + + pure + ( fromJust + ( U.fromString + (intercalate "-" (map toStr [part1, part2, part3, part4, part5])) + ) + ) \ No newline at end of file diff --git a/test/Text/Megaparsec/UtilsStreamSpec.hs b/test/Text/Megaparsec/UtilsStreamSpec.hs new file mode 100644 index 0000000..1041a92 --- /dev/null +++ b/test/Text/Megaparsec/UtilsStreamSpec.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE TypeApplications #-} + +module Text.Megaparsec.UtilsStreamSpec ( + spec, +) where + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.Text (Text) +import qualified Data.Text as T +import Data.Void (Void) +import Test.Hspec (Spec, describe, it, shouldBe) +import Test.QuickCheck (property) +import Text.Megaparsec (ParseErrorBundle, Parsec, runParser) +import qualified Text.Megaparsec.Utils.Byte as Byte +import qualified Text.Megaparsec.Utils.Char as Char +import Text.Megaparsec.Utils.Common (occurrence) + +parseText :: Parsec Void Text a -> Text -> Either (ParseErrorBundle Text Void) a +parseText p = runParser p "test" + +parseBytes + :: Parsec Void ByteString a + -> ByteString + -> Either (ParseErrorBundle ByteString Void) a +parseBytes p = runParser p "test" + +charNumParser :: Parsec Void Text Int +charNumParser = Char.numParser + +byteNumParser :: Parsec Void ByteString Int +byteNumParser = Byte.numParser + +spec :: Spec +spec = do + describe "Char parsers on Text" $ do + it "numParser" . property $ \v -> + parseText charNumParser (T.pack (show (v :: Int))) `shouldBe` Right v + + it "boolParser" $ do + parseText Char.boolParser (T.pack "yes") `shouldBe` Right True + parseText Char.boolParser (T.pack "OFF") `shouldBe` Right False + + it "uuidParser" $ do + parseText Char.uuidParser (T.pack "123e4567-e89b-12d3-a456-426614174000") + `shouldBe` Right (read "123e4567-e89b-12d3-a456-426614174000") + + it "occurrence" . property $ \v -> + parseText (occurrence charNumParser) (T.pack ("abc " <> show (v :: Int))) + `shouldBe` Right v + + describe "Byte parsers on ByteString" $ do + it "numParser" . property $ \v -> + parseBytes byteNumParser (B.pack (show (v :: Int))) `shouldBe` Right v + + it "boolParser" $ do + parseBytes Byte.boolParser (B.pack "yes") `shouldBe` Right True + parseBytes Byte.boolParser (B.pack "OFF") `shouldBe` Right False + + it "uuidParser" $ do + parseBytes Byte.uuidParser (B.pack "123e4567-e89b-12d3-a456-426614174000") + `shouldBe` Right (read "123e4567-e89b-12d3-a456-426614174000") + + it "occurrence" . property $ \v -> + parseBytes (occurrence byteNumParser) (B.pack ("abc " <> show (v :: Int))) + `shouldBe` Right v From b7b13a3604563f7cafca17e535c2d8f886fdbf08 Mon Sep 17 00:00:00 2001 From: drlkf Date: Sat, 29 Aug 2026 00:28:22 +0200 Subject: [PATCH 3/3] ci: add `@since@` auto-comments --- .github/workflows/release-helper.yaml | 30 +++ .github/workflows/semantic-release.yml | 9 + .releaserc.mjs | 33 ++- scripts/prepare-release.lisp | 290 +++++++++++++++++++++++++ scripts/prepare-release.test.lisp | 66 ++++++ 5 files changed, 417 insertions(+), 11 deletions(-) create mode 100644 .github/workflows/release-helper.yaml create mode 100755 scripts/prepare-release.lisp create mode 100755 scripts/prepare-release.test.lisp diff --git a/.github/workflows/release-helper.yaml b/.github/workflows/release-helper.yaml new file mode 100644 index 0000000..2bb6fc8 --- /dev/null +++ b/.github/workflows/release-helper.yaml @@ -0,0 +1,30 @@ +--- +name: release-helper +on: + push: + branches: main + pull_request: + branches: main + +permissions: + contents: read + +jobs: + test: + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v3 + + - name: Setup SBCL + uses: cheeze2000/setup-sbcl@v1 + + - name: Verify installation + run: >- + sbcl --non-interactive + --eval "(print (ql:client-version))" + --eval "(print (asdf:asdf-version))" + + - name: test release helper + run: | + cd scripts + ./prepare-release.test.lisp diff --git a/.github/workflows/semantic-release.yml b/.github/workflows/semantic-release.yml index e65a25c..6050dbc 100644 --- a/.github/workflows/semantic-release.yml +++ b/.github/workflows/semantic-release.yml @@ -21,6 +21,15 @@ jobs: app-id: "${{ secrets.SEMANTIC_RELEASE_APP_ID }}" private-key: "${{ secrets.SEMANTIC_RELEASE_PRIVATE_KEY }}" + - name: Setup SBCL + uses: cheeze2000/setup-sbcl@v1 + + - name: Verify installation + run: >- + sbcl --non-interactive + --eval "(print (ql:client-version))" + --eval "(print (asdf:asdf-version))" + - name: Semantic release id: semantic uses: cycjimmy/semantic-release-action@v4 diff --git a/.releaserc.mjs b/.releaserc.mjs index a878c1f..3678a2d 100644 --- a/.releaserc.mjs +++ b/.releaserc.mjs @@ -10,26 +10,37 @@ export default { { "preset": "conventionalcommits", "releaseRules": [ - { "type": "docs", "release": "patch" } - ] - } + { "type": "docs", "release": "patch" }, + ], + }, ], "@semantic-release/release-notes-generator", [ "semantic-release-mirror-version", { "fileGlob": "@(package.yaml|megaparsec-utils.cabal)", - "placeholderRegExp": "0.0.0-dev" - } + "placeholderRegExp": "0.0.0-dev", + }, ], [ - "@semantic-release/changelog", + "@semantic-release/exec", { - changelogFile: "CHANGELOG.md", - changelogTitle: "Changelog" - } + "prepareCmd": + "./scripts/prepare-release.lisp ${nextRelease.version}", + }, + ], + [ + "@semantic-release/git", + { + assets: [ + "package.yaml", + "*.cabal", + "src/**/*.hs", + "api/**/*.api", + ], + }, ], "@semantic-release/github", "semantic-release-stack-upload", - ] -} + ], +}; diff --git a/scripts/prepare-release.lisp b/scripts/prepare-release.lisp new file mode 100755 index 0000000..503ca1b --- /dev/null +++ b/scripts/prepare-release.lisp @@ -0,0 +1,290 @@ +#!/usr/bin/env -S sbcl --script + +(require :uiop) + +(defvar *run-main* t) + +(defun whitespace-p (char) + (member char '(#\Space #\Tab #\Newline #\Return))) + +(defun word-char-p (char) + (or (alphanumericp char) (char= char #\_))) + +(defun identifier-char-p (char) + (or (alphanumericp char) (member char '(#\_ #\')))) + +(defun identifier-start-p (char) + (or (alpha-char-p char) (char= char #\_))) + +(defun starts-with-p (prefix string) + (and (>= (length string) (length prefix)) + (string= prefix string :end2 (length prefix)))) + +(defun starts-with-word-p (word string) + (and (starts-with-p word string) + (let ((after (subseq string (length word)))) + (or (zerop (length after)) + (not (word-char-p (char after 0))))))) + +(defun first-uppercase-word (string) + (dolist (token (uiop:split-string string :separator '(#\Space #\Tab))) + (when (and (plusp (length token)) + (upper-case-p (char token 0))) + (return token)))) + +(defun declaration-name (line) + (let ((pos (if (and (plusp (length line)) (char= (char line 0) #\[)) 1 0))) + (when (< pos (length line)) + (let ((name nil) + (name-end nil)) + (if (char= (char line pos) #\() + (let ((close (position #\) line :start pos))) + (when close + (setf name (subseq line (1+ pos) close)) + (setf name-end (1+ close)))) + (when (identifier-start-p (char line pos)) + (let ((end (position-if-not #'identifier-char-p line :start pos))) + (setf name (subseq line pos end)) + (setf name-end end)))) + (when (and name name-end + (starts-with-p + "::" + (string-left-trim '(#\Space #\Tab) (subseq line name-end)))) + name))))) + +(defun type-declaration-name (line) + (dolist (kw '("data" "newtype" "type" "pattern")) + (when (starts-with-word-p kw line) + (let ((rest (string-left-trim '(#\Space #\Tab) (subseq line (length kw))))) + (when (starts-with-word-p "family" rest) + (setf rest (string-left-trim '(#\Space #\Tab) (subseq rest (length "family"))))) + (when (and (plusp (length rest)) + (upper-case-p (char rest 0))) + (let ((end (position-if-not #'identifier-char-p rest))) + (return (subseq rest 0 end)))))))) + +(defun parse-hoogle (input) + (let ((module-name "") + (in-class nil) + (names '())) + (dolist (line (uiop:split-string input :separator '(#\Newline))) + (let ((line (string-right-trim '(#\Return) line))) + (cond + ((starts-with-p "module " line) + (setf module-name (second (uiop:split-string line :separator '(#\Space #\Tab)))) + (setf in-class nil)) + (in-class + (when (string= (string-trim '(#\Space #\Tab) line) "}") + (setf in-class nil))) + ((starts-with-p "class " line) + (let* ((rest (subseq line (length "class "))) + (where-pos (search " where" rest))) + (when (and where-pos + (starts-with-p + "{" (string-left-trim + '(#\Space #\Tab) + (subseq rest (+ where-pos (length " where")))))) + (let ((class-name (first-uppercase-word (subseq rest 0 where-pos)))) + (when class-name + (push (format nil "~a.~a" module-name class-name) names)) + (setf in-class t))))) + ((starts-with-p "instance " line) + (let* ((rest (subseq line (length "instance "))) + (where-pos (search " where" rest))) + (push (format nil "~a.~a" module-name + (string-trim + '(#\Space #\Tab) + (if where-pos (subseq rest 0 where-pos) rest))) + names))) + ((declaration-name line) + (unless (starts-with-p "[" line) + (push (format nil "~a.~a" module-name (declaration-name line)) names))) + ((type-declaration-name line) + (push (format nil "~a.~a" module-name (type-declaration-name line)) names))))) + (sort (remove-duplicates names :test #'string=) #'string<))) + +(defun line-matches-instance-p (line name) + (let ((prefix (concatenate 'string "instance " name))) + (and (starts-with-p prefix line) + (let ((after (subseq line (length prefix)))) + (or (zerop (length after)) + (whitespace-p (char after 0))))))) + +(defun line-matches-name-p (line name) + (and (starts-with-p name line) + (let ((after (subseq line (length name)))) + (or (zerop (length after)) + (not (word-char-p (char after 0))))))) + +(defun contains-word-p (line word) + (let ((pos 0)) + (loop + (let ((found (search word line :start2 pos))) + (when (null found) + (return nil)) + (when (and (or (zerop found) (not (word-char-p (char line (1- found))))) + (let ((after (+ found (length word)))) + (or (>= after (length line)) + (not (word-char-p (char line after)))))) + (return t)) + (setf pos (1+ found)))))) + +(defun line-matches-type-decl-p (line name) + (and (some (lambda (kw) (starts-with-word-p kw line)) '("data" "newtype" "type" "class" "pattern")) + (contains-word-p line name))) + +(defun any-line-p (source predicate) + (let ((pos 0)) + (loop + (let ((line-end (or (position #\Newline source :start pos) (length source)))) + (cond ((funcall predicate (subseq source pos line-end)) + (return t)) + ((>= line-end (length source)) + (return nil)) + (t + (setf pos (1+ line-end)))))))) + +(defun is-local-declaration (source name) + (if (find #\Space name) + (any-line-p source (lambda (line) (line-matches-instance-p line name))) + (any-line-p source (lambda (line) + (or (line-matches-name-p line name) + (line-matches-type-decl-p line name)))))) + +(defun line-matches-declaration-p (line name) + (if (find #\Space name) + (line-matches-instance-p line name) + (line-matches-name-p line name))) + +(defun find-declaration (source name) + (let ((pos 0)) + (loop + (let ((line-end (or (position #\Newline source :start pos) (length source)))) + (when (line-matches-declaration-p (subseq source pos line-end) name) + (return pos)) + (when (>= line-end (length source)) + (return nil)) + (setf pos (1+ line-end)))))) + +(defun comment-block-before (source pos) + (when (and (plusp pos) (char= (char source (1- pos)) #\Newline)) + (let ((end pos) + (lines '())) + (loop + (let* ((nl (position #\Newline source :end (1- end) :from-end t)) + (line-start (if nl (1+ nl) 0))) + (let ((line (subseq source line-start end))) + (unless (starts-with-p "--" line) + (return)) + (push line lines) + (setf end line-start) + (when (zerop line-start) + (return))))) + (when lines + (format nil "~{~a~}" (nreverse lines)))))) + +(defun add-since (source name version) + (let ((match (find-declaration source name))) + (when (and match (search "@since" source)) + (let ((block (comment-block-before source match))) + (when (and block (search "@since" block)) + (return-from add-since source)))) + (unless match + (error "Cannot locate public declaration: ~a" name)) + (let ((block (comment-block-before source match))) + (if block + (concatenate 'string (subseq source 0 match) + "-- @since " version (string #\Newline) + (subseq source match)) + (concatenate 'string (subseq source 0 match) + "-- | @since " version (string #\Newline) + (subseq source match)))))) + +(defun version-line-p (line) + (and (starts-with-p "version:" line) + (let ((after (subseq line (length "version:")))) + (and (plusp (length after)) + (whitespace-p (char after 0)))))) + +(defun replace-version-line (source version) + (let ((pos 0) + (out '())) + (loop + (let ((line-end (or (position #\Newline source :start pos) (length source)))) + (let ((line (subseq source pos line-end))) + (if (version-line-p line) + (push (format nil "version: ~a" version) out) + (push line out))) + (when (>= line-end (length source)) + (return)) + (push (string #\Newline) out) + (setf pos (1+ line-end)))) + (format nil "~{~a~}" (nreverse out)))) + +(defun write-file-string (path string) + (with-open-file (stream path :direction :output :if-exists :supersede :if-does-not-exist :create) + (write-string string stream))) + +(defun update-version (path version) + (let ((source (uiop:read-file-string path))) + (write-file-string path (replace-version-line source version)))) + +(defun find-hoogle-file (root) + (let ((files '())) + (labels ((visit (dir) + (dolist (sub (uiop:subdirectories dir)) + (visit sub)) + (dolist (file (uiop:directory-files dir)) + (when (and (string= (pathname-type file) "txt") + (search "doc/html" (namestring file))) + (push (namestring file) files))))) + (visit root)) + (unless files + (error "cabal haddock did not produce a Hoogle file")) + (first (sort files #'> :key #'length)))) + +(defun read-baseline (path) + (if (probe-file path) + (remove-if (lambda (l) + (zerop (length l))) + (mapcar (lambda (l) + (string-right-trim '(#\Return) l)) + (uiop:read-file-lines path))) + '())) + +(defun main () + (let ((version (first (uiop:command-line-arguments)))) + (unless version + (error "usage: prepare-release.lisp VERSION")) + (let* ((root (uiop:getcwd)) + (package-yaml (merge-pathnames "package.yaml" root)) + (cabal (merge-pathnames "megaparsec-utils.cabal" root)) + (api-dir (merge-pathnames "api/" root)) + (baseline-path (merge-pathnames "megaparsec-utils.api" api-dir))) + (update-version package-yaml version) + (update-version cabal version) + (uiop:run-program (list "cabal" "haddock" "--haddock-hoogle") + :directory root :output t :error-output t) + (let* ((hoogle-file (find-hoogle-file (merge-pathnames "dist-newstyle/" root))) + (keys (parse-hoogle (uiop:read-file-string hoogle-file))) + (baseline (read-baseline baseline-path))) + (dolist (key (remove-if (lambda (k) (member k baseline :test #'string=)) keys)) + (let* ((dot (position #\. key :from-end t)) + (name (and dot (subseq key (1+ dot))))) + (when name + (let* ((module (subseq key 0 dot)) + (file (merge-pathnames + (format nil "~a.hs" (substitute #\/ #\. module)) + (merge-pathnames "src/" root)))) + (unless (probe-file file) + (error "Cannot locate module source for ~a" key)) + (let ((source (uiop:read-file-string file))) + (when (is-local-declaration source name) + (write-file-string file (add-since source name version)))))))) + (ensure-directories-exist baseline-path) + (write-file-string baseline-path (format nil "~{~a~%~}" keys)) + (uiop:run-program (list "cabal" "build") + :directory root :output t :error-output t))))) + +(when *run-main* + (main)) diff --git a/scripts/prepare-release.test.lisp b/scripts/prepare-release.test.lisp new file mode 100755 index 0000000..1fffe19 --- /dev/null +++ b/scripts/prepare-release.test.lisp @@ -0,0 +1,66 @@ +#!/usr/bin/env -S sbcl --script + +(require :uiop) + +(defvar *run-main* t) + +(let ((*run-main* nil)) + (load (uiop:merge-pathnames* "prepare-release.lisp" + (uiop:pathname-directory-pathname *load-pathname*)))) + +(defun assert-equal (expected actual) + (unless (equal expected actual) + (error "assertion failed:~%expected: ~s~%actual: ~s" expected actual))) + +(defun assert-true (value) + (unless value + (error "assertion failed: expected true, got ~s" value))) + +(defun assert-false (value) + (when value + (error "assertion failed: expected false, got ~s" value))) + +(let ((hoogle "@package megaparsec-utils 0.1.1 +module Text.Megaparsec.Utils +type LoggerIO = Loc -> IO () +runLoggerWith :: IOE :> es => LoggerIO -> Eff (Logger : es) a -> Eff es a +instance MonadLogger (Eff es) +[LoggerLog] :: Loc -> LogSource -> LogLevel -> LogStr -> Logger m () +class MonadLogger m where { + monadLoggerLog :: m () +} +")) + (assert-equal '("Text.Megaparsec.Utils.LoggerIO" + "Text.Megaparsec.Utils.MonadLogger" + "Text.Megaparsec.Utils.MonadLogger (Eff es)" + "Text.Megaparsec.Utils.runLoggerWith") + (parse-hoogle hoogle))) + +(assert-equal "-- | Runs the logger. +-- @since 0.1.1 +runLoggerWith :: LoggerIO -> a +" + (add-since "-- | Runs the logger. +runLoggerWith :: LoggerIO -> a +" "runLoggerWith" "0.1.1")) + +(assert-equal "-- | @since 0.1.1 +runLoggerWith :: LoggerIO -> a +" + (add-since "runLoggerWith :: LoggerIO -> a +" "runLoggerWith" "0.1.1")) + +(assert-equal "-- | @since 0.1.1 +instance MonadLogger (Eff es) +" + (add-since "instance MonadLogger (Eff es) +" "MonadLogger (Eff es)" "0.1.1")) + +(let ((source "module M (module Control.Monad.Logger, runLoggerWith) where + +runLoggerWith :: LoggerIO -> a +")) + (assert-false (is-local-declaration source "logInfoN")) + (assert-true (is-local-declaration source "runLoggerWith"))) + +(format t "All tests passed.~%")