{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module GHCup.Utils.MegaParsec where
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
import System.FilePath
import qualified Data.List.NonEmpty as NE
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' :: [f a] -> f a
choice' [] = String -> f a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Empty list"
choice' [f a
x ] = f a
x
choice' (f a
x : [f a]
xs) = f a -> f a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.try f a
x f a -> f a -> f a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [f a] -> f a
forall (f :: * -> *) e s a.
(MonadFail f, MonadParsec e s f) =>
[f a] -> f a
choice' [f a]
xs
parseUntil :: MP.Parsec Void Text a -> MP.Parsec Void Text Text
parseUntil :: Parsec Void Text a -> Parsec Void Text Text
parseUntil Parsec Void Text a
p = do
(Parsec Void Text a -> Parsec Void Text a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.try (Parsec Void Text a -> Parsec Void Text a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.lookAhead Parsec Void Text a
p) Parsec Void Text a -> Text -> Parsec Void Text Text
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Text
forall a. Monoid a => a
mempty)
Parsec Void Text Text
-> Parsec Void Text Text -> Parsec Void Text Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (do
Text
c <- Char -> Text
T.singleton (Char -> Text)
-> ParsecT Void Text Identity Char -> Parsec Void Text Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Char
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
MP.anySingle
Text
c2 <- Parsec Void Text a -> Parsec Void Text Text
forall a. Parsec Void Text a -> Parsec Void Text Text
parseUntil Parsec Void Text a
p
Text -> Parsec Void Text Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
c Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` Text
c2)
)
parseUntil1 :: MP.Parsec Void Text a -> MP.Parsec Void Text Text
parseUntil1 :: Parsec Void Text a -> Parsec Void Text Text
parseUntil1 Parsec Void Text a
p = do
Int
i1 <- ParsecT Void Text Identity Int
forall e s (m :: * -> *). MonadParsec e s m => m Int
MP.getOffset
Text
t <- Parsec Void Text a -> Parsec Void Text Text
forall a. Parsec Void Text a -> Parsec Void Text Text
parseUntil Parsec Void Text a
p
Int
i2 <- ParsecT Void Text Identity Int
forall e s (m :: * -> *). MonadParsec e s m => m Int
MP.getOffset
if Int
i1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i2 then String -> Parsec Void Text Text
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"empty parse" else Text -> Parsec Void Text Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
t
ghcTargetBinP :: Text -> MP.Parsec Void Text (Maybe Text, Text)
ghcTargetBinP :: Text -> Parsec Void Text (Maybe Text, Text)
ghcTargetBinP Text
t =
(,)
(Maybe Text -> Text -> (Maybe Text, Text))
-> ParsecT Void Text Identity (Maybe Text)
-> ParsecT Void Text Identity (Text -> (Maybe Text, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( ParsecT Void Text Identity (Maybe Text)
-> ParsecT Void Text Identity (Maybe Text)
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.try
(Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text)
-> Parsec Void Text Text -> ParsecT Void Text Identity (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parsec Void Text Text -> Parsec Void Text Text
forall a. Parsec Void Text a -> Parsec Void Text Text
parseUntil1 (Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
MP.chunk Tokens Text
"-" Parsec Void Text Text
-> Parsec Void Text Text -> Parsec Void Text Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
MP.chunk Text
Tokens Text
t) ParsecT Void Text Identity (Maybe Text)
-> Parsec Void Text Text -> ParsecT Void Text Identity (Maybe Text)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
MP.chunk Tokens Text
"-"
)
ParsecT Void Text Identity (Maybe Text)
-> ParsecT Void Text Identity (Maybe Text)
-> ParsecT Void Text Identity (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((\ Maybe Any
_ Maybe Text
x -> Maybe Text
x) Maybe Any
forall a. Maybe a
Nothing (Maybe Text -> Maybe Text)
-> ParsecT Void Text Identity (Maybe Text)
-> ParsecT Void Text Identity (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity (Maybe Text)
forall a. Monoid a => a
mempty)
)
ParsecT Void Text Identity (Text -> (Maybe Text, Text))
-> Parsec Void Text Text -> Parsec Void Text (Maybe Text, Text)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
MP.chunk Text
Tokens Text
t Parsec Void Text Text
-> ParsecT Void Text Identity () -> Parsec Void Text Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
MP.eof)
ghcProjectVersion :: MP.Parsec Void Text Version
ghcProjectVersion :: Parsec Void Text Version
ghcProjectVersion = do
Text
_ <- Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
MP.chunk Tokens Text
"ProjectVersion=\""
Text
ver <- Parsec Void Text Text -> Parsec Void Text Text
forall a. Parsec Void Text a -> Parsec Void Text Text
parseUntil1 (Parsec Void Text Text -> Parsec Void Text Text)
-> Parsec Void Text Text -> Parsec Void Text Text
forall a b. (a -> b) -> a -> b
$ Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
MP.chunk Tokens Text
"\""
Text -> ParsecT Void Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => s -> m ()
MP.setInput Text
ver
Parsec Void Text Version
version'
ghcTargetVerP :: MP.Parsec Void Text GHCTargetVersion
ghcTargetVerP :: Parsec Void Text GHCTargetVersion
ghcTargetVerP =
(\Maybe Text
x Version
y -> Maybe Text -> Version -> GHCTargetVersion
GHCTargetVersion Maybe Text
x Version
y)
(Maybe Text -> Version -> GHCTargetVersion)
-> ParsecT Void Text Identity (Maybe Text)
-> ParsecT Void Text Identity (Version -> GHCTargetVersion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT Void Text Identity (Maybe Text)
-> ParsecT Void Text Identity (Maybe Text)
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.try (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text)
-> Parsec Void Text Text -> ParsecT Void Text Identity (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parsec Void Text Text -> Parsec Void Text Text
forall a. Parsec Void Text a -> Parsec Void Text Text
parseUntil1 (Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
MP.chunk Tokens Text
"-" Parsec Void Text Text
-> Parsec Void Text Text -> Parsec Void Text Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec Void Text Text
verP') ParsecT Void Text Identity (Maybe Text)
-> Parsec Void Text Text -> ParsecT Void Text Identity (Maybe Text)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
MP.chunk Tokens Text
"-")
ParsecT Void Text Identity (Maybe Text)
-> ParsecT Void Text Identity (Maybe Text)
-> ParsecT Void Text Identity (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((\ Maybe Any
_ Maybe Text
x -> Maybe Text
x) Maybe Any
forall a. Maybe a
Nothing (Maybe Text -> Maybe Text)
-> ParsecT Void Text Identity (Maybe Text)
-> ParsecT Void Text Identity (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity (Maybe Text)
forall a. Monoid a => a
mempty)
)
ParsecT Void Text Identity (Version -> GHCTargetVersion)
-> Parsec Void Text Version -> Parsec Void Text GHCTargetVersion
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parsec Void Text Version
version' Parsec Void Text Version
-> ParsecT Void Text Identity () -> Parsec Void Text Version
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
MP.eof)
where
verP' :: MP.Parsec Void Text Text
verP' :: Parsec Void Text Text
verP' = do
Version
v <- Parsec Void Text Version
version'
let startsWithDigists :: Bool
startsWithDigists =
[Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and
([Bool] -> Bool)
-> (NonEmpty (NonEmpty VUnit) -> [Bool])
-> NonEmpty (NonEmpty VUnit)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Bool] -> [Bool]
forall a. Int -> [a] -> [a]
take Int
3
([Bool] -> [Bool])
-> (NonEmpty (NonEmpty VUnit) -> [Bool])
-> NonEmpty (NonEmpty VUnit)
-> [Bool]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty VUnit -> [Bool]) -> [NonEmpty VUnit] -> [Bool]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
((VUnit -> Bool) -> [VUnit] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map
(\case
(Digits Word
_) -> Bool
True
(Str Text
_) -> Bool
False
) ([VUnit] -> [Bool])
-> (NonEmpty VUnit -> [VUnit]) -> NonEmpty VUnit -> [Bool]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty VUnit -> [VUnit]
forall a. NonEmpty a -> [a]
NE.toList)
([NonEmpty VUnit] -> [Bool])
-> (NonEmpty (NonEmpty VUnit) -> [NonEmpty VUnit])
-> NonEmpty (NonEmpty VUnit)
-> [Bool]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (NonEmpty VUnit) -> [NonEmpty VUnit]
forall a. NonEmpty a -> [a]
NE.toList
(NonEmpty (NonEmpty VUnit) -> Bool)
-> NonEmpty (NonEmpty VUnit) -> Bool
forall a b. (a -> b) -> a -> b
$ Version -> NonEmpty (NonEmpty VUnit)
_vChunks Version
v
if Bool
startsWithDigists Bool -> Bool -> Bool
&& Maybe Word -> Bool
forall a. Maybe a -> Bool
isNothing (Version -> Maybe Word
_vEpoch Version
v)
then Text -> Parsec Void Text Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Parsec Void Text Text) -> Text -> Parsec Void Text Text
forall a b. (a -> b) -> a -> b
$ Version -> Text
prettyVer Version
v
else String -> Parsec Void Text Text
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Oh"
verP :: MP.Parsec Void Text Text -> MP.Parsec Void Text Versioning
verP :: Parsec Void Text Text -> Parsec Void Text Versioning
verP Parsec Void Text Text
suffix = do
Text
ver <- Parsec Void Text Text -> Parsec Void Text Text
forall a. Parsec Void Text a -> Parsec Void Text Text
parseUntil Parsec Void Text Text
suffix
if Text -> Bool
T.null Text
ver
then String -> Parsec Void Text Versioning
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"empty version"
else do
Text
rest <- Parsec Void Text Text
forall e s (m :: * -> *). MonadParsec e s m => m s
MP.getInput
Text -> ParsecT Void Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => s -> m ()
MP.setInput Text
ver
Versioning
v <- Parsec Void Text Versioning
versioning'
Text -> ParsecT Void Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => s -> m ()
MP.setInput Text
rest
Versioning -> Parsec Void Text Versioning
forall (f :: * -> *) a. Applicative f => a -> f a
pure Versioning
v
pathSep :: MP.Parsec Void Text Char
pathSep :: ParsecT Void Text Identity Char
pathSep = [Token Text] -> ParsecT Void Text Identity (Token Text)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
MP.oneOf String
[Token Text]
pathSeparators