Fix #2804: Text Platform roundtrip (with tests)

Cabal/Distribution/System.hs

@@ -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

Cabal/tests/UnitTests.hs

@@ -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
     ]

Cabal/tests/UnitTests/Distribution/System.hs

+{-# 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