diff --git a/Setup.hs b/Setup.hs index 9312e98..4b0b010 100644 --- a/Setup.hs +++ b/Setup.hs @@ -2,17 +2,19 @@ {-# OPTIONS_GHC -Wall #-} module Main (main) where -import Data.List ( nub ) -import Data.Version ( showVersion ) -import Distribution.Package ( PackageName(PackageName), Package, PackageId, InstalledPackageId, packageVersion, packageName ) +import Distribution.Package ( PackageName, Package, PackageId, InstalledPackageId, packageVersion, packageName, unPackageName ) import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) ) import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) -import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose, copyFiles ) +import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose, copyFiles, ordNub ) import Distribution.Simple.BuildPaths ( autogenModulesDir ) import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), Flag(..), fromFlag, HaddockFlags(haddockDistPref)) import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) ) import Distribution.Text ( display ) +import Distribution.Types.MungedPackageId ( MungedPackageId(mungedName, mungedVersion) ) +import Distribution.Types.MungedPackageName ( MungedPackageName, unMungedPackageName ) +import Distribution.Types.UnqualComponentName ( unUnqualComponentName ) import Distribution.Verbosity ( Verbosity, normal ) +import Distribution.Version ( showVersion ) import System.FilePath ( () ) main :: IO () @@ -28,15 +30,16 @@ generateBuildModule verbosity pkg lbi = do createDirectoryIfMissingVerbose verbosity True dir withLibLBI pkg lbi $ \_ libcfg -> do withTestLBI pkg lbi $ \suite suitecfg -> do - rewriteFile (dir "Build_" ++ testName suite ++ ".hs") $ unlines - [ "module Build_" ++ testName suite ++ " where" + let testSuiteName = unUnqualComponentName (testName suite) + rewriteFile (dir "Build_" ++ testSuiteName ++ ".hs") $ unlines + [ "module Build_" ++ testSuiteName ++ " where" , "deps :: [String]" , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg)) ] where formatdeps = map (formatone . snd) - formatone p = case packageName p of - PackageName n -> n ++ "-" ++ showVersion (packageVersion p) + formatone p = + unMungedPackageName (mungedName p) ++ "-" ++ showVersion (mungedVersion p) -testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)] -testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys +testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, MungedPackageId)] +testDeps xs ys = ordNub $ componentPackageDeps xs ++ componentPackageDeps ys diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal index daa6466..88ec9ba 100644 --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -32,6 +32,11 @@ Flag with-th { Default: True } +custom-setup + setup-depends: base + , Cabal >= 2.0.1.0 + , filepath + Library hs-source-dirs: source Exposed: True diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs index 0717955..334fab3 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -33,6 +33,7 @@ import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import qualified Data.Text.Encoding.Error as Text import Data.Void (Void) +import Data.Word (Word16) import Data.XML.Pickle import Data.XML.Types import qualified GHC.IO.Exception as GIE @@ -734,7 +735,7 @@ rethrowErrorCall action = do -- Provides a list of A(AAA) names and port numbers upon a successful -- DNS-SRV request, or `Nothing' if the DNS-SRV request failed. -srvLookup :: Text -> ResolvSeed -> ErrorT XmppFailure IO (Maybe [(Domain, Int)]) +srvLookup :: Text -> ResolvSeed -> ErrorT XmppFailure IO (Maybe [(Domain, Word16)]) srvLookup realm resolvSeed = ErrorT $ do result <- Ex.try $ rethrowErrorCall $ withResolver resolvSeed $ \resolver -> do @@ -764,13 +765,13 @@ srvLookup realm resolvSeed = ErrorT $ do -- 2782. It sorts the SRV results in order of priority, and then -- uses a random process to order the records with the same -- priority based on their weight. - orderSrvResult :: [(Int, Int, Int, Domain)] -> IO [(Int, Int, Int, Domain)] + orderSrvResult :: [(Word16, Word16, Word16, Domain)] -> IO [(Word16, Word16, Word16, Domain)] orderSrvResult srvResult = do -- Order the result set by priority. let srvResult' = sortBy (comparing (\(priority, _, _, _) -> priority)) srvResult -- Group elements in sublists based on their priority. The - -- type is `[[(Int, Int, Int, Domain)]]'. - let srvResult'' = Data.List.groupBy (\(priority, _, _, _) (priority', _, _, _) -> priority == priority') srvResult' :: [[(Int, Int, Int, Domain)]] + -- type is `[[(Word16, Word16, Word16, Domain)]]'. + let srvResult'' = Data.List.groupBy (\(priority, _, _, _) (priority', _, _, _) -> priority == priority') srvResult' :: [[(Word16, Word16, Word16, Domain)]] -- For each sublist, put records with a weight of zero first. let srvResult''' = Data.List.map (\sublist -> let (a, b) = partition (\(_, weight, _, _) -> weight == 0) sublist in Data.List.concat [a, b]) srvResult'' -- Order each sublist. @@ -778,7 +779,7 @@ srvLookup realm resolvSeed = ErrorT $ do -- Concatinated the results. return $ Data.List.concat srvResult'''' where - orderSublist :: [(Int, Int, Int, Domain)] -> IO [(Int, Int, Int, Domain)] + orderSublist :: [(Word16, Word16, Word16, Domain)] -> IO [(Word16, Word16, Word16, Domain)] orderSublist [] = return [] orderSublist sublist = do -- Compute the running sum, as well as the total sum of