hackport-0.6.5: cabal/cabal-install/Distribution/Deprecated/Text.hs
{-# LANGUAGE DefaultSignatures #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Deprecated.Text
-- Copyright : Duncan Coutts 2007
--
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
--
-- classes. The difference is that it uses a modern pretty printer and parser
-- system and the format is not expected to be Haskell concrete syntax but
-- rather the external human readable representation used by Cabal.
--
module Distribution.Deprecated.Text (
Text(..),
defaultStyle,
display,
flatStyle,
simpleParse,
stdParse,
-- parse utils
parsePackageName,
) where
import Distribution.Client.Compat.Prelude
import Prelude (read)
import Distribution.Deprecated.ReadP ((<++))
import qualified Distribution.Deprecated.ReadP as Parse
import Distribution.Parsec
import Distribution.Pretty
import qualified Text.PrettyPrint as Disp
import qualified Data.Set as Set
import Data.Version (Version (Version))
import qualified Distribution.Compiler as D
import qualified Distribution.License as D
import qualified Distribution.ModuleName as D
import qualified Distribution.Package as D
import qualified Distribution.PackageDescription as D
import qualified Distribution.Simple.Setup as D
import qualified Distribution.System as D
import qualified Distribution.Types.PackageVersionConstraint as D
import qualified Distribution.Types.SourceRepo as D
import qualified Distribution.Types.UnqualComponentName as D
import qualified Distribution.Version as D
import qualified Distribution.Types.VersionRange.Internal as D
import qualified Language.Haskell.Extension as E
-- | /Note:/ this class will soon be deprecated.
-- It's not yet, so that we are @-Wall@ clean.
class Text a where
disp :: a -> Disp.Doc
default disp :: Pretty a => a -> Disp.Doc
disp = pretty
parse :: Parse.ReadP r a
default parse :: Parsec a => Parse.ReadP r a
parse = parsec
-- | Pretty-prints with the default style.
display :: Text a => a -> String
display = Disp.renderStyle defaultStyle . disp
simpleParse :: Text a => String -> Maybe a
simpleParse str = case [ p | (p, s) <- Parse.readP_to_S parse str
, all isSpace s ] of
[] -> Nothing
(p:_) -> Just p
stdParse :: Text ver => (ver -> String -> res) -> Parse.ReadP r res
stdParse f = do
cs <- Parse.sepBy1 component (Parse.char '-')
_ <- Parse.char '-'
ver <- parse
let name = intercalate "-" cs
return $! f ver (lowercase name)
where
component = do
cs <- Parse.munch1 isAlphaNum
if all isDigit cs then Parse.pfail else return cs
-- each component must contain an alphabetic character, to avoid
-- ambiguity in identifiers like foo-1 (the 1 is the version number).
lowercase :: String -> String
lowercase = map toLower
-- -----------------------------------------------------------------------------
-- Instances for types from the base package
instance Text Bool where
parse = Parse.choice [ (Parse.string "True" Parse.+++
Parse.string "true") >> return True
, (Parse.string "False" Parse.+++
Parse.string "false") >> return False ]
instance Text Int where
parse = fmap negate (Parse.char '-' >> parseNat) Parse.+++ parseNat
instance Text a => Text (Identity a) where
disp = disp . runIdentity
parse = fmap Identity parse
-- | Parser for non-negative integers.
parseNat :: Parse.ReadP r Int
parseNat = read `fmap` Parse.munch1 isDigit -- TODO: eradicateNoParse
instance Text Version where
disp (Version branch _tags) -- Death to version tags!!
= Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int branch))
parse = do
branch <- Parse.sepBy1 parseNat (Parse.char '.')
-- allow but ignore tags:
_tags <- Parse.many (Parse.char '-' >> Parse.munch1 isAlphaNum)
return (Version branch [])
-------------------------------------------------------------------------------
-- Instances
-------------------------------------------------------------------------------
instance Text D.Arch where
parse = fmap (D.classifyArch D.Strict) ident
instance Text D.BuildType where
parse = do
name <- Parse.munch1 isAlphaNum
case name of
"Simple" -> return D.Simple
"Configure" -> return D.Configure
"Custom" -> return D.Custom
"Make" -> return D.Make
"Default" -> return D.Custom
_ -> fail ("unknown build-type: '" ++ name ++ "'")
instance Text D.CompilerFlavor where
parse = do
comp <- Parse.munch1 isAlphaNum
when (all isDigit comp) Parse.pfail
return (D.classifyCompilerFlavor comp)
instance Text D.CompilerId where
parse = do
flavour <- parse
version <- (Parse.char '-' >> parse) Parse.<++ return D.nullVersion
return (D.CompilerId flavour version)
instance Text D.ComponentId where
parse = D.mkComponentId `fmap` Parse.munch1 abi_char
where abi_char c = isAlphaNum c || c `elem` "-_."
instance Text D.DefUnitId where
parse = D.unsafeMkDefUnitId `fmap` parse
instance Text D.UnitId where
parse = D.mkUnitId <$> Parse.munch1 (\c -> isAlphaNum c || c `elem` "-_.+")
instance Text D.Dependency where
parse = do name <- parse
Parse.skipSpaces
libs <- Parse.option [D.LMainLibName]
$ (Parse.char ':' *>)
$ pure <$> parseLib name <|> parseMultipleLibs name
Parse.skipSpaces
ver <- parse Parse.<++ return D.anyVersion
Parse.skipSpaces
return $ D.Dependency name ver $ Set.fromList libs
where makeLib pn ln | D.unPackageName pn == ln = D.LMainLibName
| otherwise = D.LSubLibName $ D.mkUnqualComponentName ln
parseLib pn = makeLib pn <$> parsecUnqualComponentName
parseMultipleLibs pn = Parse.between (Parse.char '{' *> Parse.skipSpaces)
(Parse.skipSpaces <* Parse.char '}')
$ parsecCommaList $ parseLib pn
instance Text E.Extension where
parse = do
extension <- Parse.munch1 isAlphaNum
return (E.classifyExtension extension)
instance Text D.FlagName where
-- Note: we don't check that FlagName doesn't have leading dash,
-- cabal check will do that.
parse = D.mkFlagName . lowercase <$> parse'
where
parse' = (:) <$> lead <*> rest
lead = Parse.satisfy (\c -> isAlphaNum c || c == '_')
rest = Parse.munch (\c -> isAlphaNum c || c == '_' || c == '-')
instance Text D.HaddockTarget where
parse = Parse.choice [ Parse.string "for-hackage" >> return D.ForHackage
, Parse.string "for-development" >> return D.ForDevelopment]
instance Text E.Language where
parse = do
lang <- Parse.munch1 isAlphaNum
return (E.classifyLanguage lang)
instance Text D.License where
parse = do
name <- Parse.munch1 (\c -> isAlphaNum c && c /= '-')
version <- Parse.option Nothing (Parse.char '-' >> fmap Just parse)
return $! case (name, version :: Maybe D.Version) of
("GPL", _ ) -> D.GPL version
("LGPL", _ ) -> D.LGPL version
("AGPL", _ ) -> D.AGPL version
("BSD2", Nothing) -> D.BSD2
("BSD3", Nothing) -> D.BSD3
("BSD4", Nothing) -> D.BSD4
("ISC", Nothing) -> D.ISC
("MIT", Nothing) -> D.MIT
("MPL", Just version') -> D.MPL version'
("Apache", _ ) -> D.Apache version
("PublicDomain", Nothing) -> D.PublicDomain
("AllRightsReserved", Nothing) -> D.AllRightsReserved
("OtherLicense", Nothing) -> D.OtherLicense
_ -> D.UnknownLicense $ name ++
maybe "" (('-':) . display) version
instance Text D.Module where
parse = do
uid <- parse
_ <- Parse.char ':'
mod_name <- parse
return (D.Module uid mod_name)
instance Text D.ModuleName where
parse = do
ms <- Parse.sepBy1 component (Parse.char '.')
return (D.fromComponents ms)
where
component = do
c <- Parse.satisfy isUpper
cs <- Parse.munch validModuleChar
return (c:cs)
instance Text D.OS where
parse = fmap (D.classifyOS D.Compat) ident
instance Text D.PackageVersionConstraint where
parse = do name <- parse
Parse.skipSpaces
ver <- parse Parse.<++ return D.anyVersion
Parse.skipSpaces
return (D.PackageVersionConstraint name ver)
instance Text D.PkgconfigName where
parse = D.mkPkgconfigName
<$> Parse.munch1 (\c -> isAlphaNum c || c `elem` "+-._")
instance Text D.Platform where
-- 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 <- parseDashlessArch
_ <- Parse.char '-'
os <- parse
return (D.Platform arch os)
where
parseDashlessArch :: Parse.ReadP r D.Arch
parseDashlessArch = fmap (D.classifyArch D.Strict) dashlessIdent
dashlessIdent :: Parse.ReadP r String
dashlessIdent = liftM2 (:) firstChar rest
where firstChar = Parse.satisfy isAlpha
rest = Parse.munch (\c -> isAlphaNum c || c == '_')
instance Text D.RepoKind where
parse = fmap D.classifyRepoKind ident
instance Text D.RepoType where
parse = fmap D.classifyRepoType ident
instance Text D.UnqualComponentName where
parse = D.mkUnqualComponentName <$> parsePackageName
instance Text D.PackageIdentifier where
parse = do
n <- parse
v <- (Parse.char '-' >> parse) <++ return D.nullVersion
return (D.PackageIdentifier n v)
instance Text D.PackageName where
parse = D.mkPackageName <$> parsePackageName
instance Text D.Version where
parse = do
branch <- Parse.sepBy1 parseNat (Parse.char '.')
-- allow but ignore tags:
_tags <- Parse.many (Parse.char '-' >> Parse.munch1 isAlphaNum)
return (D.mkVersion branch)
instance Text D.VersionRange where
parse = expr
where
expr = do Parse.skipSpaces
t <- term
Parse.skipSpaces
(do _ <- Parse.string "||"
Parse.skipSpaces
e <- expr
return (D.unionVersionRanges t e)
Parse.+++
return t)
term = do f <- factor
Parse.skipSpaces
(do _ <- Parse.string "&&"
Parse.skipSpaces
t <- term
return (D.intersectVersionRanges f t)
Parse.+++
return f)
factor = Parse.choice $ parens expr
: parseAnyVersion
: parseNoVersion
: parseWildcardRange
: map parseRangeOp rangeOps
parseAnyVersion = Parse.string "-any" >> return D.anyVersion
parseNoVersion = Parse.string "-none" >> return D.noVersion
parseWildcardRange = do
_ <- Parse.string "=="
Parse.skipSpaces
branch <- Parse.sepBy1 digits (Parse.char '.')
_ <- Parse.char '.'
_ <- Parse.char '*'
return (D.withinVersion (D.mkVersion branch))
parens p = Parse.between (Parse.char '(' >> Parse.skipSpaces)
(Parse.char ')' >> Parse.skipSpaces)
(do a <- p
Parse.skipSpaces
return (D.VersionRangeParens a))
digits = do
firstDigit <- Parse.satisfy isDigit
if firstDigit == '0'
then return 0
else do rest <- Parse.munch isDigit
return (read (firstDigit : rest)) -- TODO: eradicateNoParse
parseRangeOp (s,f) = Parse.string s >> Parse.skipSpaces >> fmap f parse
rangeOps = [ ("<", D.earlierVersion),
("<=", D.orEarlierVersion),
(">", D.laterVersion),
(">=", D.orLaterVersion),
("^>=", D.majorBoundVersion),
("==", D.thisVersion) ]
-------------------------------------------------------------------------------
-- ParseUtils
-------------------------------------------------------------------------------
parsePackageName :: Parse.ReadP r String
parsePackageName = do
ns <- Parse.sepBy1 component (Parse.char '-')
return $ intercalate "-" ns
where
component = do
cs <- Parse.munch1 isAlphaNum
if all isDigit cs then Parse.pfail else return cs
-- each component must contain an alphabetic character, to avoid
-- ambiguity in identifiers like foo-1 (the 1 is the version number).
ident :: Parse.ReadP r String
ident = liftM2 (:) firstChar rest
where firstChar = Parse.satisfy isAlpha
rest = Parse.munch (\c -> isAlphaNum c || c == '_' || c == '-')
validModuleChar :: Char -> Bool
validModuleChar c = isAlphaNum c || c == '_' || c == '\''
-------------------------------------------------------------------------------
-- Rest of instances, we don't seem to need
-------------------------------------------------------------------------------
-- instance Text D.AbiDependency
-- instance Text D.AbiHash
-- instance Text D.AbiTa
-- instance Text D.BenchmarkType
-- instance Text D.ExecutableScope
-- instance Text D.ExeDependency
-- instance Text D.ExposedModule
-- instance Text D.ForeignLibOption
-- instance Text D.ForeignLibType
-- instance Text D.IncludeRenaming
-- instance Text D.KnownExtension
-- instance Text D.LegacyExeDependency
-- instance Text D.LibVersionInfo
-- instance Text D.License
-- instance Text D.Mixin
-- instance Text D.ModuleReexport
-- instance Text D.ModuleRenaming
-- instance Text D.MungedPackageName
-- instance Text D.OpenModule
-- instance Text D.OpenUnitId
-- instance Text D.PackageVersionConstraint
-- instance Text D.PkgconfigDependency
-- instance Text D.TestType