{-# LANGUAGE NoImplicitPrelude #-}

{-# LANGUAGE DeriveGeneric #-}

{-# LANGUAGE DeriveDataTypeable #-}

{-# LANGUAGE GeneralizedNewtypeDeriving #-}

-- | A ghc-pkg id.

module Stack.Types.GhcPkgId

(GhcPkgId

,unGhcPkgId

,ghcPkgIdParser

,parseGhcPkgId

,ghcPkgIdString)

where

import Stack.Prelude

import Pantry.Internal.AesonExtended

import Data.Attoparsec.Text

import qualified Data.Text as T

import Database.Persist.Sql (PersistField, PersistFieldSql)

import Prelude (Read (..))

-- | A parse fail.

newtype GhcPkgIdParseFail

= GhcPkgIdParseFail Text

deriving Typeable

instance Show GhcPkgIdParseFail where

show (GhcPkgIdParseFail bs) = "Invalid package ID: " ++ show bs

instance Exception GhcPkgIdParseFail

-- | A ghc-pkg package identifier.

newtype GhcPkgId = GhcPkgId Text

deriving (Eq,Ord,Data,Typeable,Generic,PersistField,PersistFieldSql)

instance Hashable GhcPkgId

instance NFData GhcPkgId

instance Show GhcPkgId where

show = show . ghcPkgIdString

instance Read GhcPkgId where

readsPrec i = map (first (GhcPkgId . T.pack)) . readsPrec i

instance FromJSON GhcPkgId where

parseJSON = withText "GhcPkgId" $ \t ->

case parseGhcPkgId t of

Left e -> fail $ show (e, t)

Right x -> return x

instance ToJSON GhcPkgId where

toJSON g =

toJSON (ghcPkgIdString g)

-- | Convenient way to parse a package name from a 'Text'.

parseGhcPkgId :: MonadThrow m => Text -> m GhcPkgId

parseGhcPkgId x = go x

where go =

either (const (throwM (GhcPkgIdParseFail x))) return .

parseOnly (ghcPkgIdParser <* endOfInput)

-- | A parser for a package-version-hash pair.

ghcPkgIdParser :: Parser GhcPkgId

ghcPkgIdParser =

let elements = "_.-" :: String in

GhcPkgId . T.pack <$> many1 (choice [digit, letter, satisfy (`elem` elements)])

-- | Get a string representation of GHC package id.

ghcPkgIdString :: GhcPkgId -> String

ghcPkgIdString (GhcPkgId x) = T.unpack x

-- | Get a text value of GHC package id

unGhcPkgId :: GhcPkgId -> Text

unGhcPkgId (GhcPkgId v) = v