PvpBounds.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}

{-|
Module      : Stack.Types.PvpBounds
License     : BSD-3-Clause
-}

module Stack.Types.PvpBounds
  ( PvpBounds (..)
  , PvpBoundsType (..)
  , pvpBoundsText
  , parsePvpBounds
  ) where

import           Data.Aeson.Types ( FromJSON (..), ToJSON (..), withText )
import qualified Data.Map as Map
import qualified Data.Text as T
import           Stack.Prelude

-- | How PVP bounds should be added to .cabal files
data PvpBoundsType
  = PvpBoundsNone
  | PvpBoundsUpper
  | PvpBoundsLower
  | PvpBoundsBoth
  deriving (Bounded, Enum, Eq, Ord, Read, Show)

data PvpBounds = PvpBounds
  { pbType :: !PvpBoundsType
  , pbAsRevision :: !Bool
  }
  deriving (Eq, Ord, Read, Show)

pvpBoundsText :: PvpBoundsType -> Text
pvpBoundsText PvpBoundsNone = "none"
pvpBoundsText PvpBoundsUpper = "upper"
pvpBoundsText PvpBoundsLower = "lower"
pvpBoundsText PvpBoundsBoth = "both"

parsePvpBounds :: Text -> Either String PvpBounds
parsePvpBounds t = maybe err Right $ do
  (t', asRevision) <-
    case T.break (== '-') t of
      (x, "") -> Just (x, False)
      (x, "-revision") -> Just (x, True)
      _ -> Nothing
  x <- Map.lookup t' m
  Just PvpBounds
    { pbType = x
    , pbAsRevision = asRevision
    }
 where
  m = Map.fromList $ map (pvpBoundsText &&& id) [minBound..maxBound]
  err = Left $ "Invalid PVP bounds: " ++ T.unpack t

instance ToJSON PvpBounds where
  toJSON (PvpBounds typ asRevision) =
    toJSON (pvpBoundsText typ <> (if asRevision then "-revision" else ""))

instance FromJSON PvpBounds where
  parseJSON = withText "PvpBounds" (either fail pure . parsePvpBounds)