module Distribution.Types.MungedPackageName
( MungedPackageName, unMungedPackageName, mkMungedPackageName
, computeCompatPackageName
, decodeCompatPackageName
) where
import Distribution.Compat.Prelude
import Distribution.Utils.ShortText
import Prelude ()
import Distribution.Parsec.Class
import Distribution.ParseUtils
import Distribution.Pretty
import Distribution.Text
import Distribution.Types.PackageName
import Distribution.Types.UnqualComponentName
import qualified Distribution.Compat.ReadP as Parse
import qualified Text.PrettyPrint as Disp
newtype MungedPackageName = MungedPackageName ShortText
deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)
unMungedPackageName :: MungedPackageName -> String
unMungedPackageName (MungedPackageName s) = fromShortText s
mkMungedPackageName :: String -> MungedPackageName
mkMungedPackageName = MungedPackageName . toShortText
instance IsString MungedPackageName where
fromString = mkMungedPackageName
instance Binary MungedPackageName
instance Pretty MungedPackageName where
pretty = Disp.text . unMungedPackageName
instance Parsec MungedPackageName where
parsec = mkMungedPackageName <$> parsecUnqualComponentName
instance Text MungedPackageName where
parse = mkMungedPackageName <$> parsePackageName
instance NFData MungedPackageName where
rnf (MungedPackageName pkg) = rnf pkg
computeCompatPackageName :: PackageName -> Maybe UnqualComponentName -> MungedPackageName
computeCompatPackageName pkg_name Nothing
= mkMungedPackageName $ unPackageName pkg_name
computeCompatPackageName pkg_name (Just uqn)
= mkMungedPackageName $
"z-" ++ zdashcode (unPackageName pkg_name) ++
"-z-" ++ zdashcode (unUnqualComponentName uqn)
decodeCompatPackageName :: MungedPackageName -> (PackageName, Maybe UnqualComponentName)
decodeCompatPackageName m =
case unMungedPackageName m of
'z':'-':rest | [([pn, cn], "")] <- Parse.readP_to_S parseZDashCode rest
-> (mkPackageName pn, Just (mkUnqualComponentName cn))
s -> (mkPackageName s, Nothing)
zdashcode :: String -> String
zdashcode s = go s (Nothing :: Maybe Int) []
where go [] _ r = reverse r
go ('-':z) (Just n) r | n > 0 = go z (Just 0) ('-':'z':r)
go ('-':z) _ r = go z (Just 0) ('-':r)
go ('z':z) (Just n) r = go z (Just (n+1)) ('z':r)
go (c:z) _ r = go z Nothing (c:r)
parseZDashCode :: Parse.ReadP r [String]
parseZDashCode = do
ns <- Parse.sepBy1 (Parse.many1 (Parse.satisfy (/= '-'))) (Parse.char '-')
Parse.eof
return (go ns)
where
go ns = case break (=="z") ns of
(_, []) -> [paste ns]
(as, "z":bs) -> paste as : go bs
_ -> error "parseZDashCode: go"
unZ :: String -> String
unZ "" = error "parseZDashCode: unZ"
unZ r@('z':zs) | all (=='z') zs = zs
| otherwise = r
unZ r = r
paste :: [String] -> String
paste = intercalate "-" . map unZ