module Stack.Types.GhcPkgId
(GhcPkgId
,ghcPkgIdParser
,parseGhcPkgId
,ghcPkgIdString
,ghcPkgIdPackageIdentifier)
where
import Control.Applicative
import Control.Monad.Catch
import Data.Aeson.Extended
import Data.Attoparsec.ByteString.Char8
import Data.Binary (Binary)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as S8
import Data.Char (isLetter)
import Data.Data
import Data.Hashable
import Data.Text.Encoding (encodeUtf8)
import GHC.Generics
import Prelude
import Stack.Types.PackageIdentifier
data GhcPkgIdParseFail
= GhcPkgIdParseFail ByteString
deriving Typeable
instance Show GhcPkgIdParseFail where
show (GhcPkgIdParseFail bs) = "Invalid package ID: " ++ show bs
instance Exception GhcPkgIdParseFail
data GhcPkgId =
GhcPkgId !PackageIdentifier
!ByteString
deriving (Eq,Ord,Data,Typeable,Generic)
instance Hashable GhcPkgId
instance Binary GhcPkgId
instance Show GhcPkgId where
show = show . ghcPkgIdString
instance FromJSON GhcPkgId where
parseJSON = withText "GhcPkgId" $ \t ->
case parseGhcPkgId $ encodeUtf8 t of
Left e -> fail $ show (e, t)
Right x -> return x
instance ToJSON GhcPkgId where
toJSON g =
toJSON (ghcPkgIdString g)
parseGhcPkgId :: MonadThrow m => ByteString -> m GhcPkgId
parseGhcPkgId x = go x
where go =
either (const (throwM (GhcPkgIdParseFail x))) return .
parseOnly (ghcPkgIdParser <* endOfInput)
ghcPkgIdParser :: Parser GhcPkgId
ghcPkgIdParser =
do ident <- packageIdentifierParser
_ <- char8 '-'
h <- many1 (satisfy isAlphaNum)
let !bytes = S8.pack h
return (GhcPkgId ident bytes)
where isAlphaNum c = isLetter c || isDigit c
ghcPkgIdString :: GhcPkgId -> String
ghcPkgIdString (GhcPkgId ident x) =
packageIdentifierString ident ++ "-" ++ S8.unpack x
ghcPkgIdPackageIdentifier :: GhcPkgId -> PackageIdentifier
ghcPkgIdPackageIdentifier (GhcPkgId ident _) = ident