{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
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 (..))
newtype GhcPkgIdParseFail
= GhcPkgIdParseFail Text
deriving Typeable
instance Show GhcPkgIdParseFail where
show (GhcPkgIdParseFail bs) = "Invalid package ID: " ++ show bs
instance Exception GhcPkgIdParseFail
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)
parseGhcPkgId :: MonadThrow m => Text -> m GhcPkgId
parseGhcPkgId x = go x
where go =
either (const (throwM (GhcPkgIdParseFail x))) return .
parseOnly (ghcPkgIdParser <* endOfInput)
ghcPkgIdParser :: Parser GhcPkgId
ghcPkgIdParser =
let elements = "_.-" :: String in
GhcPkgId . T.pack <$> many1 (choice [digit, letter, satisfy (`elem` elements)])
ghcPkgIdString :: GhcPkgId -> String
ghcPkgIdString (GhcPkgId x) = T.unpack x
unGhcPkgId :: GhcPkgId -> Text
unGhcPkgId (GhcPkgId v) = v