Commit 8b9143f0 authored by Oleg Grenrus's avatar Oleg Grenrus
Browse files

Fix #2804: Text Platform roundtrip (with tests)

parent b2d75687
......@@ -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)
......@@ -193,8 +198,13 @@ 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 Parse.+++ liftM2 (:) first rest'
where first = Parse.satisfy Char.isAlpha
-- We try first to parse identifier without dashes
-- This is required to parse 'Platform' properly
-- https://github.com/haskell/cabal/issues/2804
rest = Parse.munch (\c -> Char.isAlphaNum c || c == '_')
rest' = Parse.munch (\c -> Char.isAlphaNum c || 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