ghcup-hs/lib/GHCup/Prelude/MegaParsec.hs

137 lines
3.6 KiB
Haskell
Raw Permalink Normal View History

2020-04-25 10:06:41 +00:00
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
2020-07-21 23:08:58 +00:00
{-|
Module : GHCup.Utils.MegaParsec
Description : MegaParsec utilities
Copyright : (c) Julian Ospald, 2020
2020-07-30 18:04:02 +00:00
License : LGPL-3.0
2020-07-21 23:08:58 +00:00
Maintainer : hasufell@hasufell.de
Stability : experimental
2021-05-14 21:09:45 +00:00
Portability : portable
2020-07-21 23:08:58 +00:00
-}
2022-05-21 20:54:18 +00:00
module GHCup.Prelude.MegaParsec where
2020-04-25 10:06:41 +00:00
import GHCup.Types
import Control.Applicative
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Data.Functor
import Data.Maybe
import Data.Text ( Text )
import Data.Versions
import Data.Void
2021-05-14 21:09:45 +00:00
import System.FilePath
2020-04-25 10:06:41 +00:00
2020-10-24 20:55:35 +00:00
import qualified Data.List.NonEmpty as NE
2020-04-25 10:06:41 +00:00
import qualified Data.Text as T
import qualified Text.Megaparsec as MP
choice' :: (MonadFail f, MP.MonadParsec e s f) => [f a] -> f a
choice' [] = fail "Empty list"
choice' [x ] = x
choice' (x : xs) = MP.try x <|> choice' xs
parseUntil :: MP.Parsec Void Text a -> MP.Parsec Void Text Text
parseUntil p = do
(MP.try (MP.lookAhead p) $> mempty)
<|> (do
c <- T.singleton <$> MP.anySingle
c2 <- parseUntil p
pure (c `mappend` c2)
)
parseUntil1 :: MP.Parsec Void Text a -> MP.Parsec Void Text Text
parseUntil1 p = do
i1 <- MP.getOffset
t <- parseUntil p
i2 <- MP.getOffset
if i1 == i2 then fail "empty parse" else pure t
-- | Parses e.g.
-- * armv7-unknown-linux-gnueabihf-ghc
-- * armv7-unknown-linux-gnueabihf-ghci
ghcTargetBinP :: Text -> MP.Parsec Void Text (Maybe Text, Text)
ghcTargetBinP t =
(,)
<$> ( MP.try
2021-03-11 16:03:51 +00:00
(Just <$> parseUntil1 (MP.chunk "-" *> MP.chunk t) <* MP.chunk "-"
2020-04-25 10:06:41 +00:00
)
2021-03-11 16:03:51 +00:00
<|> ((\ _ x -> x) Nothing <$> mempty)
2020-04-25 10:06:41 +00:00
)
<*> (MP.chunk t <* MP.eof)
2021-04-28 16:45:48 +00:00
-- | Extracts the version from @ProjectVersion="8.10.5"@.
ghcProjectVersion :: MP.Parsec Void Text Version
ghcProjectVersion = do
_ <- MP.chunk "ProjectVersion=\""
ver <- parseUntil1 $ MP.chunk "\""
MP.setInput ver
version'
2020-04-25 10:06:41 +00:00
-- | Extracts target triple and version from e.g.
-- * armv7-unknown-linux-gnueabihf-8.8.3
-- * armv7-unknown-linux-gnueabihf-8.8.3
ghcTargetVerP :: MP.Parsec Void Text GHCTargetVersion
ghcTargetVerP =
(\x y -> GHCTargetVersion x y)
2021-03-11 16:03:51 +00:00
<$> (MP.try (Just <$> parseUntil1 (MP.chunk "-" *> verP') <* MP.chunk "-")
<|> ((\ _ x -> x) Nothing <$> mempty)
2020-04-25 10:06:41 +00:00
)
<*> (version' <* MP.eof)
where
verP' :: MP.Parsec Void Text Text
verP' = do
2020-04-25 10:06:41 +00:00
v <- version'
let startsWithDigits =
2020-04-25 10:06:41 +00:00
and
. take 3
. map (\case
Numeric _ -> True
Alphanum _ -> False)
2020-10-24 20:55:35 +00:00
. NE.toList
. (\(Chunks nec) -> nec)
2021-03-11 16:03:51 +00:00
$ _vChunks v
if startsWithDigits && isNothing (_vEpoch v)
2020-04-25 10:06:41 +00:00
then pure $ prettyVer v
else fail "Oh"
verP :: MP.Parsec Void Text Text -> MP.Parsec Void Text Versioning
verP suffix = do
ver <- parseUntil suffix
if T.null ver
then fail "empty version"
else do
rest <- MP.getInput
MP.setInput ver
v <- versioning'
MP.setInput rest
pure v
2021-05-14 21:09:45 +00:00
pathSep :: MP.Parsec Void Text Char
pathSep = MP.oneOf pathSeparators
skipWhile :: (Char -> Bool) -> MP.Parsec Void Text ()
skipWhile f = void $ MP.takeWhileP Nothing f
skip :: (Char -> Bool) -> MP.Parsec Void Text ()
skip f = void $ MP.satisfy f
skipSpace :: MP.Parsec Void Text ()
skipSpace = void $ MP.satisfy isSpace
isSpace :: Char -> Bool
isSpace c = (c == ' ') || ('\t' <= c && c <= '\r')
{-# INLINE isSpace #-}