module Stack.Types.PackageName
(PackageName
,PackageNameParseFail(..)
,packageNameParser
,parsePackageName
,parsePackageNameFromString
,packageNameByteString
,packageNameString
,packageNameText
,fromCabalPackageName
,toCabalPackageName
,parsePackageNameFromFilePath
,mkPackageName)
where
import Control.Applicative
import Control.DeepSeq
import Control.Monad
import Control.Monad.Catch
import Data.Aeson.Extended
import Data.Attoparsec.ByteString.Char8
import Data.Attoparsec.Combinators
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.Map (Map)
import qualified Data.Map as Map
import Data.Text (Text)
import qualified Data.Text.Encoding as T
import qualified Distribution.Package as Cabal
import GHC.Generics
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Path
data PackageNameParseFail
= PackageNameParseFail ByteString
| CabalFileNameParseFail FilePath
deriving (Typeable)
instance Exception PackageNameParseFail
instance Show PackageNameParseFail where
show (PackageNameParseFail bs) = "Invalid package name: " ++ show bs
show (CabalFileNameParseFail fp) = "Invalid file path for cabal file: " ++ fp
newtype PackageName =
PackageName ByteString
deriving (Eq,Ord,Typeable,Data,Generic,Hashable,Binary,NFData)
instance Lift PackageName where
lift (PackageName n) =
appE (conE 'PackageName)
(stringE (S8.unpack n))
instance Show PackageName where
show (PackageName n) = S8.unpack n
instance ToJSON PackageName where
toJSON = toJSON . packageNameText
instance FromJSON PackageName where
parseJSON j =
do s <- parseJSON j
case parsePackageNameFromString s of
Nothing ->
fail ("Couldn't parse package name: " ++ s)
Just ver -> return ver
packageNameParser :: Parser PackageName
packageNameParser =
fmap (PackageName . S8.pack)
(appending (many1 (satisfy isAlphaNum))
(concating (many (alternating
(pured (satisfy isAlphaNum))
(appending (pured (satisfy (== '-')))
(pured (satisfy isLetter)))))))
where
isAlphaNum c = isLetter c || isDigit c
mkPackageName :: String -> Q Exp
mkPackageName s =
case parsePackageNameFromString s of
Nothing -> error ("Invalid package name: " ++ show s)
Just pn -> [|pn|]
parsePackageName :: MonadThrow m => ByteString -> m PackageName
parsePackageName x = go x
where go =
either (const (throwM (PackageNameParseFail x))) return .
parseOnly (packageNameParser <* endOfInput)
parsePackageNameFromString :: MonadThrow m => String -> m PackageName
parsePackageNameFromString =
parsePackageName . S8.pack
packageNameByteString :: PackageName -> ByteString
packageNameByteString (PackageName n) = n
packageNameString :: PackageName -> String
packageNameString (PackageName n) = S8.unpack n
packageNameText :: PackageName -> Text
packageNameText (PackageName n) = T.decodeUtf8 n
fromCabalPackageName :: Cabal.PackageName -> PackageName
fromCabalPackageName (Cabal.PackageName name) =
let !x = S8.pack name
in PackageName x
toCabalPackageName :: PackageName -> Cabal.PackageName
toCabalPackageName (PackageName name) =
let !x = S8.unpack name
in Cabal.PackageName x
parsePackageNameFromFilePath :: MonadThrow m => Path a File -> m PackageName
parsePackageNameFromFilePath fp =
clean (toFilePath (filename fp)) >>= parsePackageNameFromString
where clean = liftM reverse . strip . reverse
strip ('l':'a':'b':'a':'c':'.':xs) = return xs
strip _ = throwM (CabalFileNameParseFail (toFilePath fp))
instance ToJSON a => ToJSON (Map PackageName a) where
toJSON = toJSON . Map.mapKeysWith const packageNameText
instance FromJSON a => FromJSON (Map PackageName a) where
parseJSON val = do
m <- parseJSON val
fmap Map.fromList $ mapM go $ Map.toList m
where
go (k, v) = fmap (, v) $ either (fail . show) return $ parsePackageNameFromString k