{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}

module HWM.Core.Version
  ( Version,
    Bump (..),
    askVersion,
    nextVersion,
    dropPatch,
    parseGHCVersion,
  )
where

import Data.Aeson
  ( FromJSON (..),
    ToJSON (..),
    Value (..),
  )
import qualified Data.Text as T
import GHC.Show (Show (..))
import HWM.Core.Formatting (Format (..), formatList)
import HWM.Core.Has (Has (obtain))
import HWM.Core.Parsing (Parse (..), fromToString, sepBy)
import Relude hiding (show)

data Version = Version
  { Version -> Int
major :: Int,
    Version -> Int
minor :: Int,
    Version -> [Int]
revision :: [Int]
  }
  deriving
    ( (forall x. Version -> Rep Version x)
-> (forall x. Rep Version x -> Version) -> Generic Version
forall x. Rep Version x -> Version
forall x. Version -> Rep Version x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Version -> Rep Version x
from :: forall x. Version -> Rep Version x
$cto :: forall x. Rep Version x -> Version
to :: forall x. Rep Version x -> Version
Generic,
      Version -> Version -> Bool
(Version -> Version -> Bool)
-> (Version -> Version -> Bool) -> Eq Version
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Version -> Version -> Bool
== :: Version -> Version -> Bool
$c/= :: Version -> Version -> Bool
/= :: Version -> Version -> Bool
Eq
    )

askVersion :: (MonadReader env m, Has env Version) => m Version
askVersion :: forall env (m :: * -> *).
(MonadReader env m, Has env Version) =>
m Version
askVersion = (env -> Version) -> m Version
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks env -> Version
forall env a. Has env a => env -> a
obtain

getNumber :: [Int] -> Int
getNumber :: [Int] -> Int
getNumber (Int
n : [Int]
_) = Int
n
getNumber [] = Int
0

nextVersion :: Bump -> Version -> Version
nextVersion :: Bump -> Version -> Version
nextVersion Bump
Major Version {Int
[Int]
major :: Version -> Int
minor :: Version -> Int
revision :: Version -> [Int]
major :: Int
minor :: Int
revision :: [Int]
..} = Version {major :: Int
major = Int
major Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, minor :: Int
minor = Int
0, revision :: [Int]
revision = [Int
0], ..}
nextVersion Bump
Minor Version {Int
[Int]
major :: Version -> Int
minor :: Version -> Int
revision :: Version -> [Int]
major :: Int
minor :: Int
revision :: [Int]
..} = Version {minor :: Int
minor = Int
minor Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, revision :: [Int]
revision = [Int
0], Int
major :: Int
major :: Int
..}
nextVersion Bump
Patch Version {Int
[Int]
major :: Version -> Int
minor :: Version -> Int
revision :: Version -> [Int]
major :: Int
minor :: Int
revision :: [Int]
..} = Version {revision :: [Int]
revision = [[Int] -> Int
getNumber [Int]
revision Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1], Int
major :: Int
minor :: Int
major :: Int
minor :: Int
..}

dropPatch :: Version -> Version
dropPatch :: Version -> Version
dropPatch Version {Int
[Int]
major :: Version -> Int
minor :: Version -> Int
revision :: Version -> [Int]
major :: Int
minor :: Int
revision :: [Int]
..} = Version {revision :: [Int]
revision = [Int
0], Int
major :: Int
minor :: Int
major :: Int
minor :: Int
..}

compareSeries :: (Ord a) => [a] -> [a] -> Ordering
compareSeries :: forall a. Ord a => [a] -> [a] -> Ordering
compareSeries [] [a]
_ = Ordering
EQ
compareSeries [a]
_ [] = Ordering
EQ
compareSeries (a
x : [a]
xs) (a
y : [a]
ys)
  | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y = [a] -> [a] -> Ordering
forall a. Ord a => [a] -> [a] -> Ordering
compareSeries [a]
xs [a]
ys
  | Bool
otherwise = a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
x a
y

instance Format Version where
  format :: Version -> Text
format = Text -> [Int] -> Text
forall a. Format a => Text -> [a] -> Text
formatList Text
"." ([Int] -> Text) -> (Version -> [Int]) -> Version -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> [Int]
toSeries

instance Parse Version where
  parse :: forall (m :: * -> *). MonadFail m => Text -> m Version
parse Text
s = (Text -> m Version)
-> (Version -> m Version) -> Either Text Version -> m Version
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> m Version
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m Version) -> (Text -> String) -> Text -> m Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. ToString a => a -> String
toString (Text -> String) -> (Text -> Text) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)) Version -> m Version
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Text -> Either Text [Int]
forall (m :: * -> *) a.
(MonadFail m, Parse a) =>
Text -> Text -> m [a]
sepBy Text
"." Text
s Either Text [Int]
-> ([Int] -> Either Text Version) -> Either Text Version
forall a b. Either Text a -> (a -> Either Text b) -> Either Text b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Int] -> Either Text Version
forall (m :: * -> *). MonadFail m => [Int] -> m Version
fromSeries)
    where
      prefix :: Text
prefix = Text
"invalid version(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": "

fromSeries :: (MonadFail m) => [Int] -> m Version
fromSeries :: forall (m :: * -> *). MonadFail m => [Int] -> m Version
fromSeries [] = String -> m Version
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"version should have at least one number!"
fromSeries [Int
major] = Version -> m Version
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Version {Int
major :: Int
major :: Int
major, minor :: Int
minor = Int
0, revision :: [Int]
revision = []}
fromSeries (Int
major : (Int
minor : [Int]
revision)) = Version -> m Version
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Version {Int
[Int]
major :: Int
minor :: Int
revision :: [Int]
major :: Int
minor :: Int
revision :: [Int]
..}

toSeries :: Version -> [Int]
toSeries :: Version -> [Int]
toSeries Version {Int
[Int]
major :: Version -> Int
minor :: Version -> Int
revision :: Version -> [Int]
major :: Int
minor :: Int
revision :: [Int]
..} = [Int
major, Int
minor] [Int] -> [Int] -> [Int]
forall a. Semigroup a => a -> a -> a
<> [Int]
revision

instance ToString Version where
  toString :: Version -> String
toString = Text -> String
forall a. ToString a => a -> String
toString (Text -> String) -> (Version -> Text) -> Version -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> Text
forall a. Format a => a -> Text
format

instance Ord Version where
  compare :: Version -> Version -> Ordering
compare Version
a Version
b = [Int] -> [Int] -> Ordering
forall a. Ord a => [a] -> [a] -> Ordering
compareSeries (Version -> [Int]
toSeries Version
a) (Version -> [Int]
toSeries Version
b)

instance Show Version where
  show :: Version -> String
show = Version -> String
forall a. ToString a => a -> String
toString

instance ToText Version where
  toText :: Version -> Text
toText = Version -> Text
forall a. ToString a => a -> Text
fromToString

instance FromJSON Version where
  parseJSON :: Value -> Parser Version
parseJSON (String Text
s) = Text -> Parser Version
forall a (m :: * -> *). (Parse a, MonadFail m) => Text -> m a
forall (m :: * -> *). MonadFail m => Text -> m Version
parse Text
s
  parseJSON (Number Scientific
n) = Text -> Parser Version
forall a (m :: * -> *). (Parse a, MonadFail m) => Text -> m a
forall (m :: * -> *). MonadFail m => Text -> m Version
parse (String -> Text
forall a. ToString a => a -> Text
fromToString (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Scientific -> String
forall a. Show a => a -> String
show Scientific
n)
  parseJSON Value
v = String -> Parser Version
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Version) -> String -> Parser Version
forall a b. (a -> b) -> a -> b
$ String
"version should be either true or string" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. ToString a => a -> String
toString (Value -> Text
forall a. Format a => a -> Text
format Value
v)

instance ToJSON Version where
  toJSON :: Version -> Value
toJSON = Text -> Value
String (Text -> Value) -> (Version -> Text) -> Version -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> Text
forall a. ToText a => a -> Text
toText

data Bump
  = Major
  | Minor
  | Patch
  deriving
    ( (forall x. Bump -> Rep Bump x)
-> (forall x. Rep Bump x -> Bump) -> Generic Bump
forall x. Rep Bump x -> Bump
forall x. Bump -> Rep Bump x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Bump -> Rep Bump x
from :: forall x. Bump -> Rep Bump x
$cto :: forall x. Rep Bump x -> Bump
to :: forall x. Rep Bump x -> Bump
Generic,
      Bump -> Bump -> Bool
(Bump -> Bump -> Bool) -> (Bump -> Bump -> Bool) -> Eq Bump
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Bump -> Bump -> Bool
== :: Bump -> Bump -> Bool
$c/= :: Bump -> Bump -> Bool
/= :: Bump -> Bump -> Bool
Eq
    )

instance Parse Bump where
  parse :: forall (m :: * -> *). MonadFail m => Text -> m Bump
parse Text
"major" = Bump -> m Bump
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bump
Major
  parse Text
"minor" = Bump -> m Bump
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bump
Minor
  parse Text
"patch" = Bump -> m Bump
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bump
Patch
  parse Text
v = String -> m Bump
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m Bump) -> String -> m Bump
forall a b. (a -> b) -> a -> b
$ String
"Invalid bump type: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. ToString a => a -> String
toString (Text -> Text
forall a. ToString a => a -> Text
fromToString Text
v)

instance ToString Bump where
  toString :: Bump -> String
toString Bump
Major = String
"major"
  toString Bump
Minor = String
"minor"
  toString Bump
Patch = String
"patch"

instance Format Bump where
  format :: Bump -> Text
format Bump
Major = Text
"major"
  format Bump
Minor = Text
"minor"
  format Bump
Patch = Text
"patch"

instance Show Bump where
  show :: Bump -> String
show = Bump -> String
forall a. ToString a => a -> String
toString

instance ToText Bump where
  toText :: Bump -> Text
toText = Bump -> Text
forall a. ToString a => a -> Text
fromToString

instance FromJSON Bump where
  parseJSON :: Value -> Parser Bump
parseJSON (String Text
s) = Text -> Parser Bump
forall a (m :: * -> *). (Parse a, MonadFail m) => Text -> m a
forall (m :: * -> *). MonadFail m => Text -> m Bump
parse Text
s
  parseJSON Value
v = String -> Parser Bump
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Bump) -> String -> Parser Bump
forall a b. (a -> b) -> a -> b
$ String
"Invalid bump type: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. Show a => a -> String
show Value
v

instance ToJSON Bump where
  toJSON :: Bump -> Value
toJSON = Text -> Value
String (Text -> Value) -> (Bump -> Text) -> Bump -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bump -> Text
forall a. ToText a => a -> Text
toText

parseGHCVersion :: (MonadFail m) => Text -> m Version
parseGHCVersion :: forall (m :: * -> *). MonadFail m => Text -> m Version
parseGHCVersion Text
text = Text -> m Version
forall a (m :: * -> *). (Parse a, MonadFail m) => Text -> m a
forall (m :: * -> *). MonadFail m => Text -> m Version
parse (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
text (Text -> Text -> Maybe Text
T.stripPrefix Text
"ghc-" Text
text))