Speed up versionRangeP

haskell · Jan 16, 2025 · 1bb3424 · 1bb3424
1 parent 2229287
commit 1bb3424
Show file tree

Hide file tree

Showing 4 changed files with 41 additions and 18 deletions.
diff --git a/ghcup.cabal b/ghcup.cabal
@@ -451,6 +451,7 @@ test-suite ghcup-test
     GHCup.Prelude.File.Posix.TraversalsSpec
     GHCup.Types.JSONSpec
     GHCup.Utils.FileSpec
+    GHCup.ParserSpec
     Spec
 
   default-language:   Haskell2010
@@ -477,6 +478,7 @@ test-suite ghcup-test
     , ghcup
     , hspec                     >=2.7.10  && <2.12
     , hspec-golden-aeson        ^>=0.9
+    , megaparsec                >=8.0.0    && <9.8
     , QuickCheck                ^>=2.14.1 || ^>=2.15
     , quickcheck-arbitrary-adt  ^>=0.3.1.0
     , text                      ^>=2.0 || ^>=2.1

diff --git a/lib/GHCup/Prelude/MegaParsec.hs b/lib/GHCup/Prelude/MegaParsec.hs
@@ -2,7 +2,7 @@
 {-# LANGUAGE OverloadedStrings    #-}
 
 {-|
-Module      : GHCup.Utils.MegaParsec
+Module      : GHCup.Prelude.MegaParsec
 Description : MegaParsec utilities
 Copyright   : (c) Julian Ospald, 2020
 License     : LGPL-3.0

diff --git a/lib/GHCup/Types/JSON.hs b/lib/GHCup/Types/JSON.hs
@@ -220,23 +220,16 @@ versionCmpToText (VR_lteq ver') = "<= " <> prettyV ver'
 versionCmpToText (VR_eq   ver') = "== " <> prettyV ver'
 
 versionCmpP :: MP.Parsec Void T.Text VersionCmp
-versionCmpP =
-  fmap VR_gt (MP.try $ MPC.space *> MP.chunk ">" *> MPC.space *> versioningEnd)
-    <|> fmap
-          VR_gteq
-          (MP.try $ MPC.space *> MP.chunk ">=" *> MPC.space *> versioningEnd)
-    <|> fmap
-          VR_lt
-          (MP.try $ MPC.space *> MP.chunk "<" *> MPC.space *> versioningEnd)
-    <|> fmap
-          VR_lteq
-          (MP.try $ MPC.space *> MP.chunk "<=" *> MPC.space *> versioningEnd)
-    <|> fmap
-          VR_eq
-          (MP.try $ MPC.space *> MP.chunk "==" *> MPC.space *> versioningEnd)
-    <|> fmap
-          VR_eq
-          (MP.try $ MPC.space *> versioningEnd)
+versionCmpP = either (fail . T.unpack) pure =<< (translate <$> (MPC.space *> MP.try (MP.takeWhileP Nothing (`elem` ['>', '<', '=']))) <*> (MPC.space *> versioningEnd))
+ where
+   translate ">" v  = Right $ VR_gt v
+   translate ">=" v = Right $ VR_gteq v
+   translate "<" v  = Right $ VR_lt v
+   translate "<=" v = Right $ VR_lteq v
+   translate "==" v = Right $ VR_eq v
+   translate "" v   = Right $ VR_eq v
+   translate c  _   = Left $ "unexpected comparator: " <> c
+
 
 instance ToJSON VersionRange where
   toJSON = String . verRangeToText

diff --git a/test/ghcup-test/GHCup/ParserSpec.hs b/test/ghcup-test/GHCup/ParserSpec.hs
@@ -0,0 +1,28 @@
+{-# LANGUAGE OverloadedStrings    #-}
+{-# LANGUAGE QuasiQuotes          #-}
+
+module GHCup.ParserSpec where
+
+import           GHCup.Types
+import           GHCup.Types.JSON
+import           GHCup.Prelude.Version.QQ
+
+import           Data.List.NonEmpty             ( NonEmpty (..) )
+import qualified Data.Set as Set
+import qualified Text.Megaparsec as MP
+import           Text.Megaparsec
+
+import           Test.Hspec
+
+spec :: Spec
+spec = do
+  describe "GHCup Parsers" $ do
+    it "versionRangeP" $ do
+      MP.parse versionRangeP "" ">= 8" `shouldBe` Right (SimpleRange (VR_gteq [vers|8|]:| []))
+      MP.parse versionRangeP "" "< 9" `shouldBe` Right (SimpleRange (VR_lt [vers|9|]:| []))
+      MP.parse versionRangeP "" "<= 10" `shouldBe` Right (SimpleRange (VR_lteq [vers|10|]:| []))
+      MP.parse versionRangeP "" "=< 100" `shouldBe` Left (ParseErrorBundle {bundleErrors = FancyError 6 (Set.fromList [ErrorFail "unexpected comparator: =<"]) :| [], bundlePosState = PosState {pstateInput = "=< 100", pstateOffset = 0, pstateSourcePos = SourcePos {sourceName = "", sourceLine = mkPos 1, sourceColumn = mkPos 1}, pstateTabWidth = mkPos 8, pstateLinePrefix = ""}})
+      MP.parse versionRangeP "" "> 11" `shouldBe` Right (SimpleRange (VR_gt [vers|11|]:| []))
+      MP.parse versionRangeP "" "12" `shouldBe` Right (SimpleRange (VR_eq [vers|12|]:| []))
+      MP.parse versionRangeP "" "( >= 8 && < 9 )" `shouldBe` Right (SimpleRange (VR_gteq [vers|8|]:| [VR_lt [vers|9|]]))
+      MP.parse versionRangeP "" ">= 3 || < 1" `shouldBe` Right (OrRange (VR_gteq [vers|3|]:| []) (SimpleRange (VR_lt [vers|1|]:|[])))