From bb5eed26235990a24f7cf68cd3ab1e13d84feb08 Mon Sep 17 00:00:00 2001
From: Duncan Coutts <duncan@haskell.org>
Date: Fri, 21 Mar 2008 04:12:55 +0000
Subject: [PATCH] Add Text instances for OS and Arch
---
Distribution/PackageDescription.hs | 6 +--
.../PackageDescription/Configuration.hs | 10 ++---
Distribution/System.hs | 44 +++++++++++--------
3 files changed, 33 insertions(+), 27 deletions(-)
diff --git a/Distribution/PackageDescription.hs b/Distribution/PackageDescription.hs
index a470c080eb..0fbf646f42 100644
--- a/Distribution/PackageDescription.hs
+++ b/Distribution/PackageDescription.hs
@@ -84,7 +84,7 @@ import Distribution.Package
import Distribution.Version (Version(Version), VersionRange(AnyVersion))
import Distribution.License (License(AllRightsReserved))
import Distribution.Compiler (CompilerFlavor, showCompilerFlavor)
-import Distribution.System (OS, showOS, Arch, showArch)
+import Distribution.System (OS, Arch)
import Distribution.Text
( display )
import Distribution.Simple.Utils (currentDir)
@@ -466,8 +466,8 @@ data ConfVar = OS OS
deriving Eq
instance Show ConfVar where
- show (OS os) = "os(" ++ showOS os ++ ")"
- show (Arch arch) = "arch(" ++ showArch arch ++ ")"
+ show (OS os) = "os(" ++ display os ++ ")"
+ show (Arch arch) = "arch(" ++ display arch ++ ")"
show (Flag (ConfFlag f)) = "flag(" ++ f ++ ")"
show (Impl c v) = "impl(" ++ showCompilerFlavor c
++ " " ++ display v ++ ")"
diff --git a/Distribution/PackageDescription/Configuration.hs b/Distribution/PackageDescription/Configuration.hs
index b2b32a76c6..030ebf78d3 100644
--- a/Distribution/PackageDescription/Configuration.hs
+++ b/Distribution/PackageDescription/Configuration.hs
@@ -59,7 +59,7 @@ import Distribution.Version
( Version(..), VersionRange(..), withinRange )
import Distribution.Compiler (CompilerFlavor, readCompilerFlavor)
import Distribution.System
- ( OS, readOS, Arch, readArch )
+ ( OS, Arch )
import Distribution.Simple.Utils (currentDir)
import Distribution.Text
@@ -149,15 +149,15 @@ parseCondition = condOr
+++ archCond +++ flagCond +++ implCond )
inparens = between (ReadP.char '(' >> sp) (sp >> ReadP.char ')' >> sp)
notCond = ReadP.char '!' >> sp >> cond >>= return . CNot
- osCond = string "os" >> sp >> inparens osIdent >>= return . Var . OS . readOS
- archCond = string "arch" >> sp >> inparens archIdent >>= return . Var . Arch . readArch
+ osCond = string "os" >> sp >> inparens osIdent >>= return . Var
+ archCond = string "arch" >> sp >> inparens archIdent >>= return . Var
flagCond = string "flag" >> sp >> inparens flagIdent >>= return . Var . Flag . ConfFlag
implCond = string "impl" >> sp >> inparens implIdent >>= return . Var
ident = munch1 isIdentChar >>= return . map toLower
lit = ((string "true" <++ string "True") >> return (Lit True)) <++
((string "false" <++ string "False") >> return (Lit False))
- archIdent = ident >>= return
- osIdent = ident >>= return
+ archIdent = fmap Arch parse
+ osIdent = fmap OS parse
flagIdent = ident
isIdentChar c = isAlphaNum c || (c `elem` "_-")
oper s = sp >> string s >> sp
diff --git a/Distribution/System.hs b/Distribution/System.hs
index f3bbd2a94d..6ffeeb145b 100644
--- a/Distribution/System.hs
+++ b/Distribution/System.hs
@@ -1,19 +1,19 @@
module Distribution.System (
-- * Operating System
OS(..),
- showOS,
- readOS,
buildOS,
-- * Machine Architecture
Arch(..),
- showArch,
- readArch,
buildArch,
) where
import qualified System.Info (os, arch)
-import qualified Data.Char as Char (toLower)
+import qualified Data.Char as Char (toLower, isAlphaNum)
+
+import Distribution.Text (Text(..), display)
+import qualified Distribution.Compat.ReadP as Parse
+import qualified Text.PrettyPrint as Disp
-- ------------------------------------------------------------
-- * Operating System
@@ -37,22 +37,25 @@ osAliases FreeBSD = ["kfreebsdgnu"]
osAliases Solaris = ["solaris2"]
osAliases _ = []
-showOS :: OS -> String
-showOS (OtherOS name) = name
-showOS other = lowercase (show other)
+instance Text OS where
+ disp (OtherOS name) = Disp.text name
+ disp other = Disp.text (lowercase (show other))
+
+ parse = fmap classifyOS (Parse.munch1 Char.isAlphaNum)
+ --TODO: probably should disallow starting with a number
-readOS :: String -> OS
-readOS s =
+classifyOS :: String -> OS
+classifyOS s =
case lookup (lowercase s) osMap of
Just os -> os
Nothing -> OtherOS (lowercase s)
where
osMap = [ (name, os)
| os <- knownOSs
- , name <- showOS os : osAliases os ]
+ , name <- display os : osAliases os ]
buildOS :: OS
-buildOS = readOS System.Info.os
+buildOS = classifyOS System.Info.os
-- ------------------------------------------------------------
-- * Machine Architecture
@@ -81,22 +84,25 @@ archAliases Mips = ["mipsel", "mipseb"]
archAliases Arm = ["armeb", "armel"]
archAliases _ = []
-showArch :: Arch -> String
-showArch (OtherArch name) = name
-showArch other = lowercase (show other)
+instance Text Arch where
+ disp (OtherArch name) = Disp.text name
+ disp other = Disp.text (lowercase (show other))
+
+ parse = fmap classifyArch (Parse.munch1 Char.isAlphaNum)
+ --TODO: probably should disallow starting with a number
-readArch :: String -> Arch
-readArch s =
+classifyArch :: String -> Arch
+classifyArch s =
case lookup (lowercase s) archMap of
Just arch -> arch
Nothing -> OtherArch (lowercase s)
where
archMap = [ (name, arch)
| arch <- knownArches
- , name <- showArch arch : archAliases arch ]
+ , name <- display arch : archAliases arch ]
buildArch :: Arch
-buildArch = readArch System.Info.arch
+buildArch = classifyArch System.Info.arch
lowercase :: String -> String
lowercase = map Char.toLower
--
GitLab