module Stack.Types.PackageName
(PackageName
,PackageNameParseFail(..)
,packageNameParser
,parsePackageName
,parsePackageNameFromString
,packageNameString
,packageNameText
,fromCabalPackageName
,toCabalPackageName
,parsePackageNameFromFilePath
,mkPackageName
,packageNameArgument)
where
import Control.Applicative
import Control.DeepSeq
import Control.Monad
import Control.Monad.Catch
import Data.Aeson.Extended
import Data.Attoparsec.Text
import Data.Attoparsec.Combinators
import Data.Binary.VersionTagged (Binary, HasStructuralInfo)
import Data.Data
import Data.Hashable
import Data.List (intercalate)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Binary ()
import qualified Distribution.Package as Cabal
import GHC.Generics
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Path
import qualified Options.Applicative as O
data PackageNameParseFail
= PackageNameParseFail Text
| CabalFileNameParseFail FilePath
| CabalFileNameInvalidPackageName 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, must have a .cabal extension: " ++ fp
show (CabalFileNameInvalidPackageName fp) = "cabal file names must use valid package names followed by a .cabal extension, the following is invalid: " ++ fp
newtype PackageName =
PackageName Text
deriving (Eq,Ord,Typeable,Data,Generic,Hashable,Binary,NFData)
instance Lift PackageName where
lift (PackageName n) =
appE (conE 'PackageName)
(stringE (T.unpack n))
instance Show PackageName where
show (PackageName n) = T.unpack n
instance HasStructuralInfo PackageName
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 . T.pack . intercalate "-")
(sepBy1 word (char '-'))
where
word = concat <$> sequence [many digit,
pured letter,
many (alternating letter digit)]
mkPackageName :: String -> Q Exp
mkPackageName s =
case parsePackageNameFromString s of
Nothing -> error ("Invalid package name: " ++ show s)
Just pn -> [|pn|]
parsePackageName :: MonadThrow m => Text -> 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 . T.pack
packageNameString :: PackageName -> String
packageNameString (PackageName n) = T.unpack n
packageNameText :: PackageName -> Text
packageNameText (PackageName n) = n
fromCabalPackageName :: Cabal.PackageName -> PackageName
fromCabalPackageName (Cabal.PackageName name) =
let !x = T.pack name
in PackageName x
toCabalPackageName :: PackageName -> Cabal.PackageName
toCabalPackageName (PackageName name) =
let !x = T.unpack name
in Cabal.PackageName x
parsePackageNameFromFilePath :: MonadThrow m => Path a File -> m PackageName
parsePackageNameFromFilePath fp = do
base <- clean $ toFilePath $ filename fp
case parsePackageNameFromString base of
Nothing -> throwM $ CabalFileNameInvalidPackageName $ toFilePath fp
Just x -> return x
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
packageNameArgument :: O.Mod O.ArgumentFields PackageName
-> O.Parser PackageName
packageNameArgument =
O.argument
(do s <- O.str
either O.readerError return (p s))
where
p s =
case parsePackageNameFromString s of
Just x -> Right x
Nothing -> Left ("Expected valid package name, but got: " ++ s)