Merge remote-tracking branch 'origin/pr/1229'

haskell · Feb 16, 2025 · c07d28e · c07d28e
2 parents 1fc6ddc + acc3867
commit c07d28e
Show file tree

Hide file tree

Showing 3 changed files with 41 additions and 18 deletions.
diff --git a/lib/GHCup/Prelude/MegaParsec.hs b/lib/GHCup/Prelude/MegaParsec.hs
@@ -137,3 +137,16 @@ isSpace :: Char -> Bool
 isSpace c = (c == ' ') || ('\t' <= c && c <= '\r')
 {-# INLINE isSpace #-}
 
+-- Obtain the version from the link or shim path
+-- ../ghc/<ver>/bin/ghc
+-- ../ghc/<ver>/bin/ghc-<ver>
+ghcVersionFromPath :: MP.Parsec Void Text GHCTargetVersion
+ghcVersionFromPath =
+  do
+     beforeBin <- parseUntil1 binDir <* MP.some pathSep
+     MP.setInput beforeBin
+     _ <- parseTillLastPathSep
+     ghcTargetVerP
+  where
+     binDir = MP.some pathSep <* MP.chunk "bin" *> MP.some pathSep <* MP.chunk "ghc"
+     parseTillLastPathSep = (MP.try (parseUntil1 pathSep *> MP.some pathSep) *> parseTillLastPathSep) <|> pure ()
diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs
@@ -305,23 +305,7 @@ ghcSet mtarget = do
     Just <$> ghcLinkVersion link
  where
   ghcLinkVersion :: MonadThrow m => FilePath -> m GHCTargetVersion
-  ghcLinkVersion (T.pack . dropSuffix exeExt -> t) = throwEither $ MP.parse parser "ghcLinkVersion" t
-   where
-    parser =
-        (do
-           _    <- parseUntil1 ghcSubPath
-           _    <- ghcSubPath
-           r    <- parseUntil1 pathSep
-           rest <- MP.getInput
-           MP.setInput r
-           x <- ghcTargetVerP
-           MP.setInput rest
-           pure x
-         )
-        <* MP.some pathSep
-        <* MP.takeRest
-        <* MP.eof
-    ghcSubPath = MP.some pathSep <* MP.chunk "ghc" *> MP.some pathSep
+  ghcLinkVersion (T.pack . dropSuffix exeExt -> t) = throwEither $ MP.parse ghcVersionFromPath "ghcLinkVersion" t
 
 -- | Get all installed GHCs by reading ~/.ghcup/ghc/<dir>.
 -- If a dir cannot be parsed, returns left.
@@ -1286,4 +1270,3 @@ expandVersionPattern cabalVer gitHashS gitHashL gitDescribe gitBranch
   go (GitDescribe:xs) = gitDescribe <> go xs
   go (GitBranchName:xs) = gitBranch <> go xs
   go (S str:xs) = str <> go xs
-
diff --git a/test/ghcup-test/GHCup/ParserSpec.hs b/test/ghcup-test/GHCup/ParserSpec.hs
@@ -6,9 +6,11 @@ module GHCup.ParserSpec where
 import           GHCup.Types
 import           GHCup.Types.JSON
 import           GHCup.Prelude.Version.QQ
+import           GHCup.Prelude.MegaParsec
 
 import           Data.List.NonEmpty             ( NonEmpty (..) )
 import qualified Data.Set as Set
+import           Data.Versions
 import qualified Text.Megaparsec as MP
 import           Text.Megaparsec
 
@@ -26,3 +28,28 @@ spec = do
       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|]:|[])))
+
+    it "ghcVersionFromPath" $ do
+      MP.parse ghcVersionFromPath "" "../ghc/8.10.7/bin/ghc" `shouldBe` Right ghc8107
+      MP.parse ghcVersionFromPath "" "../ghc/8.10.7/bin/ghc-8.10.7" `shouldBe` Right ghc8107
+      MP.parse ghcVersionFromPath "" "c:/ghcup/ghc/8.10.7/bin/ghc" `shouldBe` Right ghc8107
+      MP.parse ghcVersionFromPath "" "c:/ghcup/ghc/8.10.7/bin/ghc-8.10.7" `shouldBe` Right ghc8107
+      MP.parse ghcVersionFromPath "" "c:/ghc/ghcup/ghc/8.10.7/bin/ghc" `shouldBe` Right ghc8107
+      MP.parse ghcVersionFromPath "" "c:/ghc/ghcup/ghc/8.10.7/bin/ghc-8.10.7" `shouldBe` Right ghc8107
+
+      -- a user specified version
+      MP.parse ghcVersionFromPath "" "../ghc/9.4.8-rc2/bin/ghc-9.4.8" `shouldBe` Right ghc948rc2
+      MP.parse ghcVersionFromPath "" "c:/ghcup/ghc/9.4.8-rc2/bin/ghc" `shouldBe` Right ghc948rc2
+      MP.parse ghcVersionFromPath "" "c:/ghcup/ghc/9.4.8-rc2/bin/ghc-9.4.8" `shouldBe` Right ghc948rc2
+      MP.parse ghcVersionFromPath "" "c:/ghc/ghcup/ghc/9.4.8-rc2/bin/ghc" `shouldBe` Right ghc948rc2
+      MP.parse ghcVersionFromPath "" "c:/ghc/ghcup/ghc/9.4.8-rc2/bin/ghc-9.4.8" `shouldBe` Right ghc948rc2
+
+      -- a user specified alphanum
+      MP.parse ghcVersionFromPath "" "../ghc/mytag9.4.8/bin/ghc-9.4.8" `shouldBe` Right ghcMytag
+      MP.parse ghcVersionFromPath "" "c:/ghcup/ghc/mytag9.4.8/bin/ghc" `shouldBe` Right ghcMytag
+      MP.parse ghcVersionFromPath "" "c:/ghcup/ghc/mytag9.4.8/bin/ghc-9.4.8" `shouldBe` Right ghcMytag
+
+  where
+    ghc8107 = GHCTargetVersion {_tvTarget = Nothing, _tvVersion = Version {_vEpoch = Nothing, _vChunks = Chunks (Numeric 8 :| [Numeric 10,Numeric 7]), _vRel = Nothing, _vMeta = Nothing}}
+    ghc948rc2 = GHCTargetVersion {_tvTarget = Nothing, _tvVersion = Version {_vEpoch = Nothing, _vChunks = Chunks (Numeric 9 :| [Numeric 4,Numeric 8]), _vRel = Just (Release (Alphanum "rc2" :| [])), _vMeta = Nothing}}
+    ghcMytag = GHCTargetVersion {_tvTarget = Nothing, _tvVersion = Version {_vEpoch = Nothing, _vChunks = Chunks (Alphanum "mytag9" :| [Numeric 4,Numeric 8]), _vRel = Nothing, _vMeta = Nothing}}