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

Fix #2804: Text Platform roundtrip (with tests)

Cabal/Cabal.cabal

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

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

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