From 8fb4ec0aa344a930876ee8aa31d892df2510d007 Mon Sep 17 00:00:00 2001 From: Luis Morillo Date: Fri, 14 Jun 2024 08:27:48 +0200 Subject: [PATCH] rebase and port 6c59475 to new Common/Parsers --- lib-opt/GHCup/OptParse/Common.hs | 167 ------------------------------- lib/GHCup/Utils/Parsers.hs | 36 +------ 2 files changed, 4 insertions(+), 199 deletions(-) diff --git a/lib-opt/GHCup/OptParse/Common.hs b/lib-opt/GHCup/OptParse/Common.hs index 8cdbff94..14433875 100644 --- a/lib-opt/GHCup/OptParse/Common.hs +++ b/lib-opt/GHCup/OptParse/Common.hs @@ -131,173 +131,6 @@ invertableSwitch' longopt shortopt defv enmod dismod = optional - --------------------- - --[ Either Parser ]-- - --------------------- - - -platformParser :: String -> Either String PlatformRequest -platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of - Right r -> pure r - Left e -> Left $ errorBundlePretty e - where - archP :: MP.Parsec Void Text Architecture - archP = choice' ((\x -> MP.chunk (T.pack $ archToString x) $> x) <$> ([minBound..maxBound] :: [Architecture])) - platformP :: MP.Parsec Void Text PlatformRequest - platformP = choice' - [ (`PlatformRequest` FreeBSD) - <$> (archP <* MP.chunk "-") - <*> ( MP.chunk "portbld" - *> ( MP.try (Just <$> verP (MP.chunk "-freebsd" <* MP.eof)) - <|> pure Nothing - ) - <* MP.chunk "-freebsd" - ) - , (`PlatformRequest` Darwin) - <$> (archP <* MP.chunk "-") - <*> ( MP.chunk "apple" - *> ( MP.try (Just <$> verP (MP.chunk "-darwin" <* MP.eof)) - <|> pure Nothing - ) - <* MP.chunk "-darwin" - ) - , (\a d mv -> PlatformRequest a (Linux d) mv) - <$> (archP <* MP.chunk "-") - <*> distroP - <*> ((MP.try (Just <$> verP (MP.chunk "-linux" <* MP.eof)) <|> pure Nothing - ) - <* MP.chunk "-linux" - ) - , (\a -> PlatformRequest a Windows Nothing) - <$> ((archP <* MP.chunk "-") - <* (MP.chunk "unknown-mingw32" <|> MP.chunk "unknown-windows" <|> MP.chunk "windows")) - ] - distroP :: MP.Parsec Void Text LinuxDistro - distroP = choice' ((\d -> MP.chunk (T.pack $ distroToString d) $> d) <$> allDistros) - - -uriParser :: String -> Either String URI -uriParser = first show . parseURI . UTF8.fromString - - -absolutePathParser :: FilePath -> Either String FilePath -absolutePathParser f = case isValid f && isAbsolute f of - True -> Right $ normalise f - False -> Left "Please enter a valid absolute filepath." - -isolateParser :: FilePath -> Either String FilePath -isolateParser f = case isValid f && isAbsolute f of - True -> Right $ normalise f - False -> Left "Please enter a valid filepath for isolate dir." - --- this accepts cross prefix -ghcVersionTagEither :: String -> Either String ToolVersion -ghcVersionTagEither s' = - second ToolDay (dayParser s') <|> second ToolTag (tagEither s') <|> second GHCVersion (ghcVersionEither s') - --- this ignores cross prefix -toolVersionTagEither :: String -> Either String ToolVersion -toolVersionTagEither s' = - second ToolDay (dayParser s') <|> second ToolTag (tagEither s') <|> second ToolVersion (toolVersionEither s') - -tagEither :: String -> Either String Tag -tagEither s' = case fmap toLower s' of - "recommended" -> Right Recommended - "latest" -> Right Latest - "latest-prerelease" -> Right LatestPrerelease - "latest-nightly" -> Right LatestNightly - ('b':'a':'s':'e':'-':ver') -> case pvp (T.pack ver') of - Right x -> Right (Base x) - Left _ -> Left $ "Invalid PVP version for base " <> ver' - other -> Left $ "Unknown tag " <> other - - -ghcVersionEither :: String -> Either String GHCTargetVersion -ghcVersionEither = - first (const "Not a valid version") . MP.parse ghcTargetVerP "" . T.pack - -toolVersionEither :: String -> Either String Version -toolVersionEither = - first (const "Not a valid version") . MP.parse (version' <* MP.eof) "" . T.pack - - -toolParser :: String -> Either String Tool -toolParser s' | t == T.pack "ghc" = Right GHC - | t == T.pack "cabal" = Right Cabal - | t == T.pack "hls" = Right HLS - | t == T.pack "stack" = Right Stack - | otherwise = Left ("Unknown tool: " <> s') - where t = T.toLower (T.pack s') - -dayParser :: String -> Either String Day -dayParser s = maybe (Left $ "Could not parse \"" <> s <> "\". Expected format is: YYYY-MM-DD") Right - $ parseTimeM True defaultTimeLocale "%Y-%-m-%-d" s - - -criteriaParser :: String -> Either String ListCriteria -criteriaParser s' | t == T.pack "installed" = Right $ ListInstalled True - | t == T.pack "set" = Right $ ListSet True - | t == T.pack "available" = Right $ ListAvailable True - | t == T.pack "+installed" = Right $ ListInstalled True - | t == T.pack "+set" = Right $ ListSet True - | t == T.pack "+available" = Right $ ListAvailable True - | t == T.pack "-installed" = Right $ ListInstalled False - | t == T.pack "-set" = Right $ ListSet False - | t == T.pack "-available" = Right $ ListAvailable False - | otherwise = Left ("Unknown criteria: " <> s') - where t = T.toLower (T.pack s') - - - -keepOnParser :: String -> Either String KeepDirs -keepOnParser s' | t == T.pack "always" = Right Always - | t == T.pack "errors" = Right Errors - | t == T.pack "never" = Right Never - | otherwise = Left ("Unknown keep value: " <> s') - where t = T.toLower (T.pack s') - - -downloaderParser :: String -> Either String Downloader -downloaderParser s' | t == T.pack "curl" = Right Curl - | t == T.pack "wget" = Right Wget -#if defined(INTERNAL_DOWNLOADER) - | t == T.pack "internal" = Right Internal -#endif - | otherwise = Left ("Unknown downloader value: " <> s') - where t = T.toLower (T.pack s') - -gpgParser :: String -> Either String GPGSetting -gpgParser s' | t == T.pack "strict" = Right GPGStrict - | t == T.pack "lax" = Right GPGLax - | t == T.pack "none" = Right GPGNone - | otherwise = Left ("Unknown gpg setting value: " <> s') - where t = T.toLower (T.pack s') - - - -overWriteVersionParser :: String -> Either String [VersionPattern] -overWriteVersionParser = first (const "Not a valid version pattern") . MP.parse (MP.many versionPattern <* MP.eof) "" . T.pack - where - versionPattern :: MP.Parsec Void Text VersionPattern - versionPattern = do - str' <- T.unpack <$> MP.takeWhileP Nothing (/= '%') - if str' /= mempty - then pure (S str') - else fmap (const CabalVer) v_cabal - <|> fmap (const GitBranchName) b_name - <|> fmap (const GitHashShort) s_hash - <|> fmap (const GitHashLong) l_hash - <|> fmap (const GitDescribe) g_desc - <|> ((\a b -> S (a : T.unpack b)) <$> MP.satisfy (const True) <*> MP.takeWhileP Nothing (== '%')) -- invalid pattern, e.g. "%k" - where - v_cabal = MP.chunk "%v" - b_name = MP.chunk "%b" - s_hash = MP.chunk "%h" - l_hash = MP.chunk "%H" - g_desc = MP.chunk "%g" - - - ------------------ --[ Completers ]-- ------------------ diff --git a/lib/GHCup/Utils/Parsers.hs b/lib/GHCup/Utils/Parsers.hs index 42415666..6a593637 100644 --- a/lib/GHCup/Utils/Parsers.hs +++ b/lib/GHCup/Utils/Parsers.hs @@ -86,7 +86,7 @@ platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of Left e -> Left $ errorBundlePretty e where archP :: MP.Parsec Void Text Architecture - archP = MP.try (MP.chunk "x86_64" $> A_64) <|> (MP.chunk "i386" $> A_32) + archP = choice' ((\x -> MP.chunk (T.pack $ archToString x) $> x) <$> ([minBound..maxBound] :: [Architecture])) platformP :: MP.Parsec Void Text PlatformRequest platformP = choice' [ (`PlatformRequest` FreeBSD) @@ -112,6 +112,9 @@ platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of ) <* MP.chunk "-linux" ) + , (\a -> PlatformRequest a Windows Nothing) + <$> ((archP <* MP.chunk "-") + <* (MP.chunk "unknown-mingw32" <|> MP.chunk "unknown-windows" <|> MP.chunk "windows")) ] distroP :: MP.Parsec Void Text LinuxDistro distroP = choice' ((\d -> MP.chunk (T.pack $ distroToString d) $> d) <$> allDistros) @@ -387,34 +390,3 @@ parseNewUrlSource "GHCupURL" = pure NewGHCupURL parseNewUrlSource "StackSetupURL" = pure NewStackSetupURL parseNewUrlSource s' = (eitherDecode . LE.encodeUtf8 . LT.pack $ s') <|> (fmap NewURI . first show . parseURI .UTF8.fromString $ s') - - -checkForUpdates :: ( MonadReader env m - , HasGHCupInfo env - , HasDirs env - , HasPlatformReq env - , MonadCatch m - , HasLog env - , MonadThrow m - , MonadIO m - , MonadFail m - ) - => m [(Tool, GHCTargetVersion)] -checkForUpdates = do - GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo - lInstalled <- listVersions Nothing [ListInstalled True] False False (Nothing, Nothing) - let latestInstalled tool = (fmap (\lr -> GHCTargetVersion (lCross lr) (lVer lr)) . lastMay . filter (\lr -> lTool lr == tool)) lInstalled - - ghcup <- forMM (getLatest dls GHCup) $ \(GHCTargetVersion _ l, _) -> do - (Right ghcup_ver) <- pure $ version $ prettyPVP ghcUpVer - if (l > ghcup_ver) then pure $ Just (GHCup, mkTVer l) else pure Nothing - - otherTools <- forM [GHC, Cabal, HLS, Stack] $ \t -> - forMM (getLatest dls t) $ \(l, _) -> do - let mver = latestInstalled t - forMM mver $ \ver -> - if (l > ver) then pure $ Just (t, l) else pure Nothing - - pure $ catMaybes (ghcup:otherTools) - where - forMM a f = fmap join $ forM a f \ No newline at end of file