Skip to content

Fix #2804: Text Platform roundtrip (with tests) #2862

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 4 commits into from
Oct 12, 2015
Merged

Fix #2804: Text Platform roundtrip (with tests) #2862

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
4 commits
Select commit Hold shift + click to select a range
8b9143f
Fix #2804: Text Platform roundtrip (with tests)
phadej Oct 11, 2015
22b4553
Add UnitTests.Distribution.System module to cabal file
phadej Oct 11, 2015
e1ca4f4
Make Text Platform parse unambigious
phadej Oct 11, 2015
9d206e1
Make ident parser accept dash again
phadej Oct 12, 2015
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions Cabal/Cabal.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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,
Expand Down
32 changes: 27 additions & 5 deletions Cabal/Distribution/System.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down Expand Up @@ -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
Expand All @@ -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)
Expand All @@ -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
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Looks like ident is now identical to dashlessIdent. Is this intentional?

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

My bad, ident should have dash. Will fix shortly.

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
Expand Down
3 changes: 3 additions & 0 deletions Cabal/tests/UnitTests.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
]
Expand Down
29 changes: 29 additions & 0 deletions Cabal/tests/UnitTests/Distribution/System.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,29 @@
{-# 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