Commit 63a2c9c7 authored by Mikhail Glushenkov's avatar Mikhail Glushenkov
Browse files

Merge pull request #2862 from phadej/2804-platform-roundtrip

Fix #2804: Text Platform roundtrip (with tests)
parents b2d75687 9d206e1a
......@@ -273,6 +273,7 @@ test-suite unit-tests
UnitTests.Distribution.Compat.ReadP
UnitTests.Distribution.Simple.Program.Internal
UnitTests.Distribution.Utils.NubList
UnitTests.Distribution.System
main-is: UnitTests.hs
build-depends:
base,
......
......@@ -28,12 +28,17 @@ module Distribution.System (
-- * Platform is a pair of arch and OS
Platform(..),
buildPlatform,
platformFromTriple
platformFromTriple,
-- * Internal
knownOSs,
knownArches
) where
import qualified System.Info (os, arch)
import qualified Data.Char as Char (toLower, isAlphaNum)
import qualified Data.Char as Char (toLower, isAlphaNum, isAlpha)
import Control.Monad (liftM2)
import Distribution.Compat.Binary (Binary)
import Data.Data (Data)
import Data.Typeable (Typeable)
......@@ -156,6 +161,10 @@ instance Text Arch where
parse = fmap (classifyArch Strict) ident
-- See the comment in instance Text Platform definition
parseDashlessArch :: Parse.ReadP r Arch
parseDashlessArch = fmap (classifyArch Strict) dashlessIdent
classifyArch :: ClassificationStrictness -> String -> Arch
classifyArch strictness s =
fromMaybe (OtherArch s) $ lookup (lowercase s) archMap
......@@ -178,8 +187,15 @@ instance Binary Platform
instance Text Platform where
disp (Platform arch os) = disp arch <> Disp.char '-' <> disp os
-- TODO: there are ambigious platforms like: `arch-word-os`
-- which could be parsed as
-- * Platform "arch-word" "os"
-- * Platform "arch" "word-os"
-- We could support that preferring variants 'OtherOS' or 'OtherArch'
--
-- For now we split into arch and os parts on the first dash.
parse = do
arch <- parse
arch <- parseDashlessArch
_ <- Parse.char '-'
os <- parse
return (Platform arch os)
......@@ -193,8 +209,14 @@ buildPlatform = Platform buildArch buildOS
-- Utils:
ident :: Parse.ReadP r String
ident = Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-')
--TODO: probably should disallow starting with a number
ident = liftM2 (:) first rest
where first = Parse.satisfy Char.isAlpha
rest = Parse.munch (\c -> Char.isAlphaNum c || c == '_' || c == '-')
dashlessIdent :: Parse.ReadP r String
dashlessIdent = liftM2 (:) first rest
where first = Parse.satisfy Char.isAlpha
rest = Parse.munch (\c -> Char.isAlphaNum c || c == '_')
lowercase :: String -> String
lowercase = map Char.toLower
......
......@@ -8,6 +8,7 @@ import qualified UnitTests.Distribution.Compat.CreatePipe
import qualified UnitTests.Distribution.Compat.ReadP
import qualified UnitTests.Distribution.Simple.Program.Internal
import qualified UnitTests.Distribution.Utils.NubList
import qualified UnitTests.Distribution.System
import qualified Test.Distribution.Version (versionTests, parseTests)
tests :: TestTree
......@@ -20,6 +21,8 @@ tests = testGroup "Unit Tests" $
UnitTests.Distribution.Simple.Program.Internal.tests
, testGroup "Distribution.Utils.NubList"
UnitTests.Distribution.Utils.NubList.tests
, testGroup "Distribution.System"
UnitTests.Distribution.System.tests
, Test.Distribution.Version.versionTests
, Test.Distribution.Version.parseTests
]
......
{-# OPTIONS_GHC -fno-warn-orphans #-}
module UnitTests.Distribution.System
( tests
) where
import Control.Monad (liftM2)
import Distribution.Text (Text(..), display, simpleParse)
import Distribution.System
import Test.Tasty
import Test.Tasty.QuickCheck
textRoundtrip :: (Arbitrary a, Show a, Eq a, Text a) => a -> Property
textRoundtrip x = simpleParse (display x) === Just x
tests :: [TestTree]
tests =
[ testProperty "Text OS round trip" (textRoundtrip :: OS -> Property)
, testProperty "Text Arch round trip" (textRoundtrip :: Arch -> Property)
, testProperty "Text Platform round trip" (textRoundtrip :: Platform -> Property)
]
instance Arbitrary OS where
arbitrary = elements knownOSs
instance Arbitrary Arch where
arbitrary = elements knownArches
instance Arbitrary Platform where
arbitrary = liftM2 Platform arbitrary arbitrary
\ No newline at end of file
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment