{-# LANGUAGE CPP                  #-}
{-# LANGUAGE OverloadedStrings    #-}

{-|
Module      : GHCup.Utils.MegaParsec
Description : MegaParsec utilities
Copyright   : (c) Julian Ospald, 2020
License     : LGPL-3.0
Maintainer  : hasufell@hasufell.de
Stability   : experimental
Portability : portable
-}
module GHCup.Prelude.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' :: forall (f :: * -> *) e s a.
(MonadFail f, MonadParsec e s f) =>
[f a] -> f a
choice' []       = 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) = forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.try f a
x forall (f :: * -> *) a. Alternative f => 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 :: forall a. Parsec Void Text a -> Parsec Void Text Text
parseUntil Parsec Void Text a
p = do
  (forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.try (forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.lookAhead Parsec Void Text a
p) forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> forall a. Monoid a => a
mempty)
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (do
          Text
c  <- Char -> Text
T.singleton forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
MP.anySingle
          Text
c2 <- forall a. Parsec Void Text a -> Parsec Void Text Text
parseUntil Parsec Void Text a
p
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
c forall a. Monoid a => a -> a -> a
`mappend` Text
c2)
        )

parseUntil1 :: MP.Parsec Void Text a -> MP.Parsec Void Text Text
parseUntil1 :: forall a. Parsec Void Text a -> Parsec Void Text Text
parseUntil1 Parsec Void Text a
p = do
  Int
i1 <- forall e s (m :: * -> *). MonadParsec e s m => m Int
MP.getOffset
  Text
t <- forall a. Parsec Void Text a -> Parsec Void Text Text
parseUntil Parsec Void Text a
p
  Int
i2 <- forall e s (m :: * -> *). MonadParsec e s m => m Int
MP.getOffset
  if Int
i1 forall a. Eq a => a -> a -> Bool
== Int
i2 then forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"empty parse" else forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
t



-- | Parses e.g.
--   * armv7-unknown-linux-gnueabihf-ghc
--   * armv7-unknown-linux-gnueabihf-ghci
ghcTargetBinP :: Text -> MP.Parsec Void Text (Maybe Text, Text)
ghcTargetBinP :: Text -> Parsec Void Text (Maybe Text, Text)
ghcTargetBinP Text
t =
  (,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (   forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.try
            (forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parsec Void Text a -> Parsec Void Text Text
parseUntil1 (forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
MP.chunk Tokens Text
"-" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
MP.chunk Text
t) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
MP.chunk Tokens Text
"-"
            )
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((\ Maybe Any
_ Maybe Text
x -> Maybe Text
x) forall a. Maybe a
Nothing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Monoid a => a
mempty)
        )
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
MP.chunk Text
t forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *). MonadParsec e s m => m ()
MP.eof)


-- | Extracts the version from @ProjectVersion="8.10.5"@.
ghcProjectVersion :: MP.Parsec Void Text Version
ghcProjectVersion :: Parsec Void Text Version
ghcProjectVersion = do
  Tokens Text
_ <- forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
MP.chunk Tokens Text
"ProjectVersion=\""
  Text
ver <- forall a. Parsec Void Text a -> Parsec Void Text Text
parseUntil1 forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
MP.chunk Tokens Text
"\""
  forall e s (m :: * -> *). MonadParsec e s m => s -> m ()
MP.setInput Text
ver
  Parsec Void Text Version
version'


-- | 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 :: Parsec Void Text GHCTargetVersion
ghcTargetVerP =
  (\Maybe Text
x Version
y -> Maybe Text -> Version -> GHCTargetVersion
GHCTargetVersion Maybe Text
x Version
y)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
MP.try (forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parsec Void Text a -> Parsec Void Text Text
parseUntil1 (forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
MP.chunk Tokens Text
"-" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec Void Text Text
verP') forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
MP.chunk Tokens Text
"-")
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((\ Maybe Any
_ Maybe Text
x -> Maybe Text
x) forall a. Maybe a
Nothing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Monoid a => a
mempty)
        )
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parsec Void Text Version
version' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* 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 =
          forall (t :: * -> *). Foldable t => t Bool -> Bool
and
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
take Int
3
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
              (forall a b. (a -> b) -> [a] -> [b]
map
                (\case
                  (Digits Word
_) -> Bool
True
                  (Str    Text
_) -> Bool
False
                ) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> [a]
NE.toList)
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> [a]
NE.toList
            forall a b. (a -> b) -> a -> b
$ Version -> NonEmpty VChunk
_vChunks Version
v
    if Bool
startsWithDigists Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isNothing (Version -> Maybe Word
_vEpoch Version
v)
      then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Version -> Text
prettyVer Version
v
      else 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 <- forall a. Parsec Void Text a -> Parsec Void Text Text
parseUntil Parsec Void Text Text
suffix
  if Text -> Bool
T.null Text
ver
    then forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"empty version"
    else do
      Text
rest <- forall e s (m :: * -> *). MonadParsec e s m => m s
MP.getInput
      forall e s (m :: * -> *). MonadParsec e s m => s -> m ()
MP.setInput Text
ver
      Versioning
v <- Parsec Void Text Versioning
versioning'
      forall e s (m :: * -> *). MonadParsec e s m => s -> m ()
MP.setInput Text
rest
      forall (f :: * -> *) a. Applicative f => a -> f a
pure Versioning
v


pathSep :: MP.Parsec Void Text Char
pathSep :: Parsec Void Text Char
pathSep = forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
MP.oneOf String
pathSeparators