From 1bb3424ee14260357124e84e3f0d7fd0894e6453 Mon Sep 17 00:00:00 2001
From: Julian Ospald <hasufell@posteo.de>
Date: Thu, 16 Jan 2025 15:38:22 +0800
Subject: [PATCH] Speed up versionRangeP

---
 ghcup.cabal                         |  2 ++
 lib/GHCup/Prelude/MegaParsec.hs     |  2 +-
 lib/GHCup/Types/JSON.hs             | 27 ++++++++++-----------------
 test/ghcup-test/GHCup/ParserSpec.hs | 28 ++++++++++++++++++++++++++++
 4 files changed, 41 insertions(+), 18 deletions(-)
 create mode 100644 test/ghcup-test/GHCup/ParserSpec.hs

diff --git a/ghcup.cabal b/ghcup.cabal
index 15f1607d..6d4f0e85 100644
--- 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
index 01b7580b..d3ddb217 100644
--- 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
index aeb00c8e..53310c25 100644
--- 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
new file mode 100644
index 00000000..d83fa2a3
--- /dev/null
+++ 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|]:|[])))