{-# 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.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



-- | 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 =
  (,)
    (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)


-- | Extracts the version from @ProjectVersion="8.10.5"@.
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'


-- | 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)
    (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