{-# LANGUAGE QuasiQuotes       #-}


{-|
Module      : GHCup.Version
Description : Version information and version handling.
Copyright   : (c) Julian Ospald, 2020
License     : LGPL-3.0
Maintainer  : hasufell@hasufell.de
Stability   : experimental
Portability : portable
-}
module GHCup.Version where

import           GHCup.Types
import           Paths_ghcup (version)

import           Data.Version (Version(versionBranch))
import           URI.ByteString
import           URI.ByteString.QQ

import qualified Data.List.NonEmpty            as NE
import qualified Data.Text                     as T
import qualified Data.Versions as V
import Control.Exception.Safe (MonadThrow)
import Data.Text (Text)
import Data.List.NonEmpty (NonEmpty((:|)))
import Data.List (intersperse)
import Control.Monad.Catch (throwM)
import GHCup.Errors (ParseError(..))

-- | This reflects the API version of the YAML.
--
-- Note that when updating this, CI requires that the file exsists AND the same file exists at
-- 'https://www.haskell.org/ghcup/exp/ghcup-<ver>.yaml' with some newlines added.
ghcupURL :: URI
ghcupURL :: URI
ghcupURL = [uri|https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-0.0.7.yaml|]

-- | The current ghcup version.
ghcUpVer :: V.PVP
ghcUpVer :: PVP
ghcUpVer = NonEmpty Word -> PVP
V.PVP (NonEmpty Word -> PVP) -> ([Int] -> NonEmpty Word) -> [Int] -> PVP
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word] -> NonEmpty Word
forall a. [a] -> NonEmpty a
NE.fromList ([Word] -> NonEmpty Word)
-> ([Int] -> [Word]) -> [Int] -> NonEmpty Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Word) -> [Int] -> [Word]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Int] -> PVP) -> [Int] -> PVP
forall a b. (a -> b) -> a -> b
$ Version -> [Int]
versionBranch Version
version

-- | ghcup version as numeric string.
numericVer :: String
numericVer :: String
numericVer = Text -> String
T.unpack (Text -> String) -> (PVP -> Text) -> PVP -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PVP -> Text
V.prettyPVP (PVP -> String) -> PVP -> String
forall a b. (a -> b) -> a -> b
$ PVP
ghcUpVer

versionCmp :: V.Versioning -> VersionCmp -> Bool
versionCmp :: Versioning -> VersionCmp -> Bool
versionCmp Versioning
ver1 (VR_gt Versioning
ver2)   = Versioning
ver1 Versioning -> Versioning -> Bool
forall a. Ord a => a -> a -> Bool
> Versioning
ver2
versionCmp Versioning
ver1 (VR_gteq Versioning
ver2) = Versioning
ver1 Versioning -> Versioning -> Bool
forall a. Ord a => a -> a -> Bool
>= Versioning
ver2
versionCmp Versioning
ver1 (VR_lt Versioning
ver2)   = Versioning
ver1 Versioning -> Versioning -> Bool
forall a. Ord a => a -> a -> Bool
< Versioning
ver2
versionCmp Versioning
ver1 (VR_lteq Versioning
ver2) = Versioning
ver1 Versioning -> Versioning -> Bool
forall a. Ord a => a -> a -> Bool
<= Versioning
ver2
versionCmp Versioning
ver1 (VR_eq Versioning
ver2)   = Versioning
ver1 Versioning -> Versioning -> Bool
forall a. Eq a => a -> a -> Bool
== Versioning
ver2

versionRange :: V.Versioning -> VersionRange -> Bool
versionRange :: Versioning -> VersionRange -> Bool
versionRange Versioning
ver' (SimpleRange NonEmpty VersionCmp
cmps) = NonEmpty Bool -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and (NonEmpty Bool -> Bool) -> NonEmpty Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (VersionCmp -> Bool) -> NonEmpty VersionCmp -> NonEmpty Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Versioning -> VersionCmp -> Bool
versionCmp Versioning
ver') NonEmpty VersionCmp
cmps
versionRange Versioning
ver' (OrRange NonEmpty VersionCmp
cmps VersionRange
range) = 
  Versioning -> VersionRange -> Bool
versionRange Versioning
ver' (NonEmpty VersionCmp -> VersionRange
SimpleRange NonEmpty VersionCmp
cmps) Bool -> Bool -> Bool
|| Versioning -> VersionRange -> Bool
versionRange Versioning
ver' VersionRange
range

pvpToVersion :: MonadThrow m => V.PVP -> Text -> m V.Version
pvpToVersion :: PVP -> Text -> m Version
pvpToVersion PVP
pvp_ Text
rest =
  (ParsingError -> m Version)
-> (Version -> m Version)
-> Either ParsingError Version
-> m Version
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\ParsingError
_ -> ParseError -> m Version
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ParseError -> m Version) -> ParseError -> m Version
forall a b. (a -> b) -> a -> b
$ String -> ParseError
ParseError String
"Couldn't convert PVP to Version") Version -> m Version
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ParsingError Version -> m Version)
-> (PVP -> Either ParsingError Version) -> PVP -> m Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either ParsingError Version
V.version (Text -> Either ParsingError Version)
-> (PVP -> Text) -> PVP -> Either ParsingError Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rest) (Text -> Text) -> (PVP -> Text) -> PVP -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PVP -> Text
V.prettyPVP (PVP -> m Version) -> PVP -> m Version
forall a b. (a -> b) -> a -> b
$ PVP
pvp_

-- | Convert a version to a PVP and unparsable rest.
--
-- -- prop> \v -> let (Just (pvp', r)) = versionToPVP v in pvpToVersion pvp' r === Just v
versionToPVP :: MonadThrow m => V.Version -> m (V.PVP, Text)
versionToPVP :: Version -> m (PVP, Text)
versionToPVP (V.Version (Just Word
_) NonEmpty VChunk
_ [VChunk]
_ Maybe Text
_) = ParseError -> m (PVP, Text)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ParseError -> m (PVP, Text)) -> ParseError -> m (PVP, Text)
forall a b. (a -> b) -> a -> b
$ String -> ParseError
ParseError String
"Unexpected epoch"
versionToPVP Version
v = (ParsingError -> m (PVP, Text))
-> (PVP -> m (PVP, Text))
-> Either ParsingError PVP
-> m (PVP, Text)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\ParsingError
_ -> (, Version -> Text
rest Version
v) (PVP -> (PVP, Text)) -> m PVP -> m (PVP, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Version -> m PVP
forall (m :: * -> *). MonadThrow m => Version -> m PVP
alternative Version
v) ((PVP, Text) -> m (PVP, Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((PVP, Text) -> m (PVP, Text))
-> (PVP -> (PVP, Text)) -> PVP -> m (PVP, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (, Text
forall a. Monoid a => a
mempty)) (Either ParsingError PVP -> m (PVP, Text))
-> (Version -> Either ParsingError PVP) -> Version -> m (PVP, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either ParsingError PVP
V.pvp (Text -> Either ParsingError PVP)
-> (Version -> Text) -> Version -> Either ParsingError PVP
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> Text
V.prettyVer (Version -> m (PVP, Text)) -> Version -> m (PVP, Text)
forall a b. (a -> b) -> a -> b
$ Version
v
 where
  alternative :: MonadThrow m => V.Version -> m V.PVP
  alternative :: Version -> m PVP
alternative Version
v' = case (VChunk -> Bool) -> NonEmpty VChunk -> [VChunk]
forall a. (a -> Bool) -> NonEmpty a -> [a]
NE.takeWhile VChunk -> Bool
isDigit (Version -> NonEmpty VChunk
V._vChunks Version
v') of
    [] -> ParseError -> m PVP
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ParseError -> m PVP) -> ParseError -> m PVP
forall a b. (a -> b) -> a -> b
$ String -> ParseError
ParseError String
"Couldn't convert Version to PVP"
    [VChunk]
xs -> PVP -> m PVP
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PVP -> m PVP) -> PVP -> m PVP
forall a b. (a -> b) -> a -> b
$ [Int] -> PVP
pvpFromList (VChunk -> Int
unsafeDigit (VChunk -> Int) -> [VChunk] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [VChunk]
xs)

  rest :: V.Version -> Text
  rest :: Version -> Text
rest (V.Version Maybe Word
_ NonEmpty VChunk
cs [VChunk]
pr Maybe Text
me) =
    let chunks :: [VChunk]
chunks = (VChunk -> Bool) -> NonEmpty VChunk -> [VChunk]
forall a. (a -> Bool) -> NonEmpty a -> [a]
NE.dropWhile VChunk -> Bool
isDigit NonEmpty VChunk
cs
        ver :: [Text]
ver = Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
intersperse (String -> Text
T.pack String
".") ([Text] -> [Text]) -> ([VChunk] -> [Text]) -> [VChunk] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [VChunk] -> [Text]
forall (t :: * -> *). Functor t => t VChunk -> t Text
chunksAsT ([VChunk] -> [Text]) -> [VChunk] -> [Text]
forall a b. (a -> b) -> a -> b
$ [VChunk]
chunks
        me' :: [Text]
me' = [Text] -> (Text -> [Text]) -> Maybe Text -> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Text
m -> [String -> Text
T.pack String
"+",Text
m]) Maybe Text
me
        pr' :: [Text]
pr' = [Text] -> ([Text] -> [Text]) -> [Text] -> [Text]
forall (f :: * -> *) b a.
Foldable f =>
f b -> (f a -> f b) -> f a -> f b
foldable [] (String -> Text
T.pack String
"-" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:) ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
intersperse (String -> Text
T.pack String
".") ([VChunk] -> [Text]
forall (t :: * -> *). Functor t => t VChunk -> t Text
chunksAsT [VChunk]
pr)
        prefix :: Text
prefix = case ([Text]
ver, [Text]
pr', [Text]
me') of
                   (Text
_:[Text]
_, [Text]
_, [Text]
_) -> String -> Text
T.pack String
"."
                   ([Text], [Text], [Text])
_           -> String -> Text
T.pack String
""
    in Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text]
ver [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
pr' [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
me')
   where
    chunksAsT :: Functor t => t V.VChunk -> t Text
    chunksAsT :: t VChunk -> t Text
chunksAsT = (VChunk -> Text) -> t VChunk -> t Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((VUnit -> Text) -> VChunk -> Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap VUnit -> Text
f)
      where
        f :: V.VUnit -> Text
        f :: VUnit -> Text
f (V.Digits Word
i) = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Word -> String
forall a. Show a => a -> String
show Word
i
        f (V.Str Text
s)    = Text
s

    foldable :: Foldable f => f b -> (f a -> f b) -> f a -> f b
    foldable :: f b -> (f a -> f b) -> f a -> f b
foldable f b
d f a -> f b
g f a
f | f a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null f a
f    = f b
d
                   | Bool
otherwise = f a -> f b
g f a
f



  isDigit :: V.VChunk -> Bool
  isDigit :: VChunk -> Bool
isDigit (V.Digits Word
_ :| []) = Bool
True
  isDigit VChunk
_                = Bool
False

  unsafeDigit :: V.VChunk -> Int
  unsafeDigit :: VChunk -> Int
unsafeDigit (V.Digits Word
x :| []) = Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
x
  unsafeDigit VChunk
_ = String -> Int
forall a. HasCallStack => String -> a
error String
"unsafeDigit: wrong input"

pvpFromList :: [Int] -> V.PVP
pvpFromList :: [Int] -> PVP
pvpFromList = NonEmpty Word -> PVP
V.PVP (NonEmpty Word -> PVP) -> ([Int] -> NonEmpty Word) -> [Int] -> PVP
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word] -> NonEmpty Word
forall a. [a] -> NonEmpty a
NE.fromList ([Word] -> NonEmpty Word)
-> ([Int] -> [Word]) -> [Int] -> NonEmpty Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Word) -> [Int] -> [Word]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral