hackport-0.6.4: 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 Data.Functor.Identity (Identity (..))
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