|
sourcecode:
|
module CPM.Package
( Version, initialVersion, nextMajor, nextMinor
, VersionConstraint (..)
, CompilerCompatibility (..)
, Package (..), emptyPackage
, Dependency (..)
, execOfPackage
, showVersion
, replaceVersionInTag
, readVersion
, packageIdEq
, showSourceOfPackage
, readVersionConstraint
, readVersionConstraints
, readPackageSpec
, sourceDirsOf
, dependencyNames
, vlt
, vlte
, vgt
, vgte
, isPreRelease
, packageId
, PackageId (..)
, PackageSource (..)
, GitRevision (..)
, PackageExecutable (..), PackageTest (..), PackageDocumentation (..)
, showDependency
, showCompilerDependency
, showVersionConstraints
, Conjunction, Disjunction
, packageSpecFile, loadPackageSpec, writePackageSpec, packageSpecToJSON
) where
import Data.Char
import Data.Either
import Data.List ( intercalate, intersperse, isInfixOf, splitOn )
import System.FilePath ( (</>) )
import System.Directory ( doesFileExist )
import System.IOExts ( readCompleteFile )
import JSON.Data
import JSON.Parser
import JSON.Pretty ( ppJSON )
import Test.Prop
import Prelude hiding ( (<$>), (<*>), (<*), (*>), (<|>), some, empty )
import DetParse
import CPM.ErrorLogger
------------------------------------------------------------------------------
-- Data types to represent package specifications.
--- Data type representing a version number.
--- It is a tuple where the components are the major, minor, patch numbers
--- a possible prerelease string.
--- For instance, `(3,1,0,Just "rc5")` denotes the version `3.1.0-rc5`.
type Version = (Int, Int, Int, Maybe String)
--- The initial version of a new package.
initialVersion :: Version
initialVersion = (0,0,1,Nothing)
--- The next major version of a given version.
nextMajor :: Version -> Version
nextMajor (maj,_,_,_) = (maj + 1, 0, 0, Nothing)
--- The next minor version of a given version.
nextMinor :: Version -> Version
nextMinor (maj,min,_,_) = (maj, min + 1, 0, Nothing)
--- A conjunction of version constraints.
type Conjunction = [VersionConstraint]
--- A disjunction of conjunctions of version constraints.
type Disjunction = [Conjunction]
--- A dependency on another package. The disjunctive normal form of a boolean
--- combination of version constraints is represented by a list of lists of
--- version constraint. Each inner list of version constraints is a conjunction,
--- the outer list is a disjunction.
data Dependency = Dependency String Disjunction
deriving (Eq,Show,Read)
--- A version constraint.
--- @cons VExact - versions must match exactly
--- @cons VGt - version must be strictly larger than specified version
--- @cons VLt - version must be strictly smaller than specified version
--- @cons VGte - version must be larger or equal to specified version
--- @cons VLte - version must be smaller or equal to specified version
--- @cons VMinCompatible - version must be larger or equal and
--- within same minor version
--- @cons VMajCompatible - version must be larger or equal and
--- within same major version
data VersionConstraint = VExact Version
| VGt Version
| VLt Version
| VGte Version
| VLte Version
| VMinCompatible Version
| VMajCompatible Version
deriving (Eq,Show,Read)
--- Compiler compatibility constraint, takes the name of the compiler (kics2 or
--- pakcs), as well as a disjunctive normal form combination of version
--- constraints (see Dependency).
data CompilerCompatibility = CompilerCompatibility String Disjunction
deriving (Eq,Show,Read)
--- A package id consisting of the package name and version.
data PackageId = PackageId String Version
--- The specification to generate an executable from the package.
--- It consists of the name of the executable, the name of the main
--- module (which must contain an operation `main`), and list
--- of options for various compilers (i.e., pairs of compiler name and
--- options for this compiler).
data PackageExecutable = PackageExecutable String String [(String,String)]
deriving (Eq,Show,Read)
--- The specification of a single test suite for a package.
--- It consists of a directory, a list of modules, options (for CurryCheck),
--- and a name of a test script in this directory.
--- The test script can be empty, but then a non-empty list of modules must be
--- provided.
--- This structure specifies a test which is performed in the given directory
--- by running CurryCheck on the given list of modules where the option
--- string is passed to CurryCheck.
data PackageTest = PackageTest String [String] String String
deriving (Eq,Show)
--- The specification to generate the documentation of the package.
--- It consists of the name of the directory containing the documentation,
--- a main file (usually, a LaTeX file) containing the documentation,
--- and a command to generate the documentation. If the command is missing
--- and the main file has the suffix "tex", e.g., "manual.tex",
--- the default command is "pdflatex manual.tex".
data PackageDocumentation = PackageDocumentation String String String
deriving (Eq,Show)
--- A source where the contents of a package can be acquired.
--- @cons Http - URL to a ZIP file
--- @cons Git - URL to a Git repository and an optional revision spec to check
--- out
--- @cons FileSource - The path to a ZIP file to install. Cannot be specified in
--- a package specification file, for internal use only.
data PackageSource = Http String
| Git String (Maybe GitRevision)
| FileSource String
deriving (Eq,Show)
--- A Git revision.
--- @cons Tag - A tag which might contain the string `$version$` which will
--- be replaced by the package version
--- @cons Ref - A Git 'commitish', i.e. a SHA, a branch name, a tag name etc.
--- @cons VersionAsTag - Use the package version prefixed with a 'v' as the tag
data GitRevision = Tag String
| Ref String
| VersionAsTag
deriving (Eq,Show)
--- The data type for package specifications.
--- The name of a package may contain any ASCII alphanumeric character
--- as well as dashes (`-`) and underscores (`_`).
--- It must start with an alphanumeric character.
--- The suggested format of authors and maintainers is either
--- a name (`John Doe`) or a name followed by an email address in angle brackets
--- (`John Doe <john.doe@goldenstate.gov>`).
data Package = Package {
name :: String
, version :: Version
, author :: [String]
, maintainer :: [String]
, synopsis :: String
, description :: Maybe String
, category :: [String]
, license :: Maybe String
, licenseFile :: Maybe String
, copyright :: Maybe String
, homepage :: Maybe String
, bugReports :: Maybe String
, repository :: Maybe String
, dependencies :: [Dependency]
, compilerCompatibility :: [CompilerCompatibility]
, source :: Maybe PackageSource
, sourceDirs :: [String]
, exportedModules :: [String]
, configModule :: Maybe String
, executableSpec :: [PackageExecutable]
, testSuite :: Maybe [PackageTest]
, documentation :: Maybe PackageDocumentation
}
deriving (Eq,Show)
-- A simple Show instance for Package (maybe useful for debugging):
--instance Show Package where
-- show p = "(Package " ++
-- unwords [name p, showVersion (version p)
-- , unwords (map showDependency (dependencies p))] ++ ")"
--- An empty package specification.
emptyPackage :: Package
emptyPackage = Package {
name = ""
, version = initialVersion
, author = []
, maintainer = []
, synopsis = ""
, description = Nothing
, category = []
, license = Nothing
, licenseFile = Nothing
, copyright = Nothing
, homepage = Nothing
, bugReports = Nothing
, repository = Nothing
, dependencies = []
, compilerCompatibility = []
, source = Nothing
, sourceDirs = []
, exportedModules = []
, configModule = Nothing
, executableSpec = []
, testSuite = Nothing
, documentation = Nothing
}
--- Returns the names of the executables of the package.
--- Returns the empty string if the package has no executable to install.
execOfPackage :: Package -> String
execOfPackage p =
unwords (map (\ (PackageExecutable e _ _) -> e) (executableSpec p))
------------------------------------------------------------------------------
--- The name of the package specification file in JSON format.
packageSpecFile :: String
packageSpecFile = "package.json"
--- Translates a package to a JSON object.
packageSpecToJSON :: Package -> JValue
packageSpecToJSON pkg = JObject $
[ ("name", JString $ name pkg)
, ("version", JString $ showVersion $ version pkg) ] ++
(case author pkg of [] -> [("author", JString "")]
[s] -> [("author", JString s)]
xs -> stringListToJSON "author" xs) ++
(case maintainer pkg of [] -> []
[s] -> [ ("maintainer", JString s) ]
xs -> stringListToJSON "maintainer" xs) ++
[ ("synopsis", JString $ synopsis pkg) ] ++
maybeStringToJSON "description" (description pkg) ++
stringListToJSON "category" (category pkg) ++
maybeStringToJSON "license" (license pkg) ++
maybeStringToJSON "licenseFile" (licenseFile pkg) ++
maybeStringToJSON "copyright" (copyright pkg) ++
maybeStringToJSON "homepage" (homepage pkg) ++
maybeStringToJSON "bugReports" (bugReports pkg) ++
maybeStringToJSON "repository" (repository pkg) ++
[ ("dependencies", dependenciesToJSON $ dependencies pkg) ] ++
compilerCompatibilityToJSON (compilerCompatibility pkg) ++
stringListToJSON "exportedModules" (exportedModules pkg) ++
stringListToJSON "sourceDirs" (sourceDirs pkg) ++
maybeStringToJSON "configModule" (configModule pkg) ++
(case executableSpec pkg of
[] -> []
[e] -> [("executable", execToJSON e)]
es -> [("executables", JArray $ map execToJSON es)]) ++
maybeTestToJSON (testSuite pkg) ++
maybeDocuToJSON (documentation pkg) ++
maybeSourceToJSON (source pkg)
where
dependenciesToJSON deps = JObject $ map dependencyToJSON deps
where dependencyToJSON (Dependency p vc) =
(p, JString $ showVersionConstraints vc)
compilerCompatibilityToJSON deps =
if null deps
then []
else [("compilerCompatibility", JObject $ map compatToJSON deps)]
where compatToJSON (CompilerCompatibility p vc) =
(p, JString $ showVersionConstraints vc)
maybeSourceToJSON =
maybe [] (\src -> [("source", JObject (pkgSourceToJSON src))])
where
pkgSourceToJSON (FileSource _) =
error "Internal error: FileSource in package specification"
pkgSourceToJSON (Http url) = [("http", JString url)]
pkgSourceToJSON (Git url mbrev) =
[("git", JString url)] ++ maybe [] revToJSON mbrev
where
revToJSON (Ref t) = [("ref", JString t)]
revToJSON (Tag t) = [("tag", JString t)]
revToJSON VersionAsTag = [("tag", JString "$version")]
execToJSON (PackageExecutable ename emain eopts) =
JObject $ [ ("name", JString ename), ("main", JString emain)] ++ exOptsToJSON
where
exOptsToJSON =
if null eopts then []
else [("options",
JObject $ map (\ (c,o) -> (c, JString o)) eopts)]
maybeTestToJSON = maybe [] (\tests -> [("testsuite", testsToJSON tests)])
where
testsToJSON tests = if length tests == 1
then testToJSON (head tests)
else JArray $ map testToJSON tests
testToJSON (PackageTest dir mods opts script) = JObject $
[ ("src-dir", JString dir) ] ++
(if null opts then [] else [("options", JString opts)]) ++
stringListToJSON "modules" mods ++
(if null script then [] else [("script", JString script)])
maybeDocuToJSON =
maybe [] (\ (PackageDocumentation docdir docmain doccmd) ->
[("documentation",
JObject $ [ ("src-dir", JString docdir)
, ("main", JString docmain)] ++
if null doccmd
then []
else [("command", JString doccmd)] )])
stringListToJSON fname exps =
if null exps then []
else [(fname, JArray $ map JString exps)]
maybeStringToJSON fname = maybe [] (\s -> [(fname, JString s)])
--- Writes a package specification to a file in JSON format.
---
--- @param pkg the package specification to write
--- @param file the file name to write to
writePackageSpec :: Package -> String -> IO ()
writePackageSpec pkg file = writeFile file $ ppJSON $ packageSpecToJSON pkg
--- Loads a package specification from a package directory.
---
--- @param the directory containing the `package.json` file
loadPackageSpec :: String -> ErrorLogger Package
loadPackageSpec dir = do
let packageFile = dir </> packageSpecFile
exfile <- liftIOEL $ doesFileExist packageFile
if exfile
then do logDebug $ "Reading package specification '" ++ packageFile ++ "'..."
contents <- liftIOEL $ readCompleteFile packageFile
case readPackageSpec contents of
Left err -> fail err
Right v -> return v
else fail $ "Illegal package: file `" ++ packageFile ++ "' does not exist!"
--- Checks whether two package ids are equal, i.e. if their names and versions
--- match.
---
--- @param p1 the first package
--- @param p2 the second package
packageIdEq :: Package -> Package -> Bool
packageIdEq p1 p2 = name p1 == name p2 && version p1 == version p2
--- Shows the package source in human-readable format.
showSourceOfPackage :: Package -> String
showSourceOfPackage pkg = case source pkg of
Nothing -> "No source specified"
Just s -> showSource s
where
showSource :: PackageSource -> String
showSource (Git url rev) = "Git " ++ url ++ showGitRev rev
showSource (Http url) = url
showSource (FileSource url) = "File " ++ url
showGitRev (Just (Ref ref)) = "@" ++ ref
showGitRev (Just (Tag tag)) = "@" ++ replaceVersionInTag pkg tag
showGitRev (Just VersionAsTag) = "@v" ++ (showVersion $ version pkg)
showGitRev Nothing = ""
--- Replace the string `$version$` in a tag string by the current version.
replaceVersionInTag :: Package -> String -> String
replaceVersionInTag pkg =
concat . intersperse (showVersion $ version pkg) . splitOn "$version$"
--- Less than operator for versions.
vlt :: Version -> Version -> Bool
vlt (majorA, minorA, patchA, preA) (majorB, minorB, patchB, preB) =
major || minor || patch || pre
where
major = majorA < majorB
minor = majorA <= majorB && minorA < minorB
patch = majorA <= majorB && minorA <= minorB && patchA < patchB
pre = case preA of
Nothing -> case preB of
Nothing -> patch
Just _ -> majorA <= majorB && minorA <= minorB && patchA <= patchB
Just a -> case preB of
Nothing -> False
Just b -> a `ltPre` b
ltPre :: String -> String -> Bool
ltPre a b | isNumeric a && isNumeric b = (read a :: Int) < read b
| isNumeric a = True
| isNumeric b = False
| otherwise = a `ltShortlex` b
isNumeric :: String -> Bool
isNumeric = all isDigit
ltShortlex :: String -> String -> Bool
ltShortlex a b = (length a == length b && a < b) || length a < length b
test_shorterPrereleaseIsSmaller :: Prop
test_shorterPrereleaseIsSmaller =
always $ (0, 0, 0, Just "rc") `vlt` (0, 0, 0, Just "beta")
test_numericIsSmallerLeft :: Prop
test_numericIsSmallerLeft =
always $ (0, 0, 0, Just "1234") `vlt` (0, 0, 0, Just "rc")
test_numericIsSmallerRight :: Prop
test_numericIsSmallerRight =
always $ not $ (0, 0, 0, Just "rc") `vlt` (0, 0, 0, Just "1234")
test_numbersAreComparedNumerically :: Prop
test_numbersAreComparedNumerically =
always $ (0, 0, 0, Just "0003") `vlt` (0, 0, 0, Just "123")
--- Less than or equal operator for versions.
vlte :: Version -> Version -> Bool
vlte a b = a `vlt` b || a == b
--- Greater than operator for versions.
vgt :: Version -> Version -> Bool
vgt (majorA, minorA, patchA, preA) (majorB, minorB, patchB, preB) =
major || minor || patch || pre
where
major = majorA > majorB
minor = majorA >= majorB && minorA > minorB
patch = majorA >= majorB && minorA >= minorB && patchA > patchB
pre = case preA of
Nothing -> case preB of Nothing -> patch
Just _ -> False
Just a -> case preB of Nothing -> False
Just b -> a > b
--- Greater than or equal operator for versions.
vgte :: Version -> Version -> Bool
vgte a b = a `vgt` b || a == b
--- Is the version a pre-release version?
isPreRelease :: Version -> Bool
isPreRelease (_, _, _, Nothing) = False
isPreRelease (_, _, _, Just _) = True
--- Gets the list of source directories of a package.
--- It is either the field `sourceDirs` (if non-empty) or `["src"]`.
sourceDirsOf :: Package -> [String]
sourceDirsOf p =
if null (sourceDirs p) then ["src"]
else sourceDirs p
--- Gets the package names of all dependencies of a package.
dependencyNames :: Package -> [String]
dependencyNames p = map (\(Dependency s _) -> s) $ dependencies p
--- Renders a dependency as a string, including all version constraints.
showDependency :: Dependency -> String
showDependency (Dependency p vcs) = p ++ showVersionConstraints vcs
--- Renders a compiler dependency as a string, including all version
--- constraints.
showCompilerDependency :: CompilerCompatibility -> String
showCompilerDependency (CompilerCompatibility cc vcs) =
cc ++ showVersionConstraints vcs
--- Renders a list of version constraints in disjunctive normal form.
showVersionConstraints :: [[VersionConstraint]] -> String
showVersionConstraints =
intercalate " || " . map (intercalate ", " . map showVersionConstraint)
--- Renders a single version constraint as a string.
showVersionConstraint :: VersionConstraint -> String
showVersionConstraint (VLt v) = " < " ++ showVersion v
showVersionConstraint (VLte v) = " <= " ++ showVersion v
showVersionConstraint (VGt v) = " > " ++ showVersion v
showVersionConstraint (VGte v) = " >= " ++ showVersion v
showVersionConstraint (VExact v) = " = " ++ showVersion v
showVersionConstraint (VMinCompatible v) = " ~" ++ showVersion v
showVersionConstraint (VMajCompatible v) = " ^" ++ showVersion v
--- Renders the id of a package as a string. Package name and version separated
--- by a dash.
packageId :: Package -> String
packageId p = name p ++ "-" ++ showVersion (version p)
--- Reads a package spec from a JSON string.
readPackageSpec :: String -> Either String Package
readPackageSpec s = case parseJSON s of
Nothing -> Left "Invalid JSON"
Just j -> case j of
JObject kv -> packageSpecFromJObject kv
_ -> Left "Expected a JSON object."
--- Reads a package spec from the key-value-pairs of a JObject.
packageSpecFromJObject :: [(String, JValue)] -> Either String Package
packageSpecFromJObject kv =
mandatoryString "name" kv $ \nameS ->
mandatoryString "version" kv $ \versionS ->
getStringOrStringList True "An author" "author" $ \author ->
getStringOrStringList False "A maintainer" "maintainer" $ \maintainer ->
mandatoryString "synopsis" kv $ \synopsisS ->
optionalString "description" kv $ \description ->
getStringList "A category" "category" $ \categories ->
optionalString "license" kv $ \license ->
optionalString "licenseFile" kv $ \licenseFile ->
optionalString "copyright" kv $ \copyright ->
optionalString "homepage" kv $ \homepage ->
optionalString "bugReports" kv $ \bugReports ->
optionalString "repository" kv $ \repository ->
optionalString "configModule" kv $ \configModule ->
mustBePackageName nameS $ \name ->
mustBeVersion versionS $ \version ->
mustBeSynopsis synopsisS $ \synopsis ->
getDependencies $ \dependencies ->
getSource $ \source ->
getStringList "A source directory" "sourceDirs" $ \sourcedirs ->
getStringList "An exported module" "exportedModules" $ \exportedModules ->
getCompilerCompatibility $ \compilerCompatibility ->
getExecutableSpec $ \executable ->
getElemList (elemsFromJArray execSpecFromJValue) "executables" $ \executables ->
getTestSuite $ \testsuite ->
getDocumentationSpec $ \docspec ->
Right Package {
name = name
, version = version
, author = author
, maintainer = maintainer
, synopsis = synopsis
, description = description
, category = categories
, license = license
, licenseFile = licenseFile
, copyright = copyright
, homepage = homepage
, bugReports = bugReports
, repository = repository
, dependencies = dependencies
, compilerCompatibility = compilerCompatibility
, source = source
, sourceDirs = sourcedirs
, exportedModules = exportedModules
, configModule = configModule
, executableSpec = executable ++ executables
, testSuite = testsuite
, documentation = docspec
}
where
mustBePackageName s@(c:cs) f =
if isAlphaNum c && all (\d -> isAlphaNum d || d == '-' || d == '_') cs
then f s
else Left $ "'" ++ s ++ "' is not a valid package name."
mustBePackageName [] _ = Left "Package name is empty."
mustBeSynopsis s f
| null s = Left "Synopsis is empty: add a short description."
| otherwise = f s
mustBeVersion :: String -> (Version -> Either String a) -> Either String a
mustBeVersion s f = case readVersion s of
Nothing -> Left $ "'" ++ s ++ "' is not a valid version specification."
Just v -> f v
getDependencies :: ([Dependency] -> Either String a) -> Either String a
getDependencies f = case lookup "dependencies" kv of
Nothing -> f []
Just (JObject ds) -> case dependenciesFromJObject ds of
Left e -> Left e
Right ds' -> f ds'
Just (JString _) -> Left $ "Expected an object, got a string" ++ forKey
Just (JArray _) -> Left $ "Expected an object, got an array" ++ forKey
Just (JNumber _) -> Left $ "Expected an object, got a number" ++ forKey
Just JTrue -> Left $ "Expected an object, got 'true'" ++ forKey
Just JFalse -> Left $ "Expected an object, got 'false'" ++ forKey
Just JNull -> Left $ "Expected an object, got 'null'" ++ forKey
where forKey = " for key 'dependencies'"
getCompilerCompatibility :: ([CompilerCompatibility] -> Either String a)
-> Either String a
getCompilerCompatibility f = case lookup "compilerCompatibility" kv of
Nothing -> f []
Just (JObject ds) -> case compilerCompatibilityFromJObject ds of
Left e -> Left e
Right ds' -> f ds'
Just (JString _) -> Left $ "Expected an object, got a string" ++ forKey
Just (JArray _) -> Left $ "Expected an object, got an array" ++ forKey
Just (JNumber _) -> Left $ "Expected an object, got a number" ++ forKey
Just JTrue -> Left $ "Expected an object, got 'true'" ++ forKey
Just JFalse -> Left $ "Expected an object, got 'false'" ++ forKey
Just JNull -> Left $ "Expected an object, got 'null'" ++ forKey
where forKey = " for key 'compilerCompatibility'"
getSource :: (Maybe PackageSource -> Either String a) -> Either String a
getSource f = case lookup "source" kv of
Nothing -> f Nothing
Just (JObject s) -> case sourceFromJObject s of
Left e -> Left e
Right s' -> f (Just s')
Just (JString _) -> Left $ "Expected an object, got a string" ++ forKey
Just (JArray _) -> Left $ "Expected an object, got an array" ++ forKey
Just (JNumber _) -> Left $ "Expected an object, got a number" ++ forKey
Just JTrue -> Left $ "Expected an object, got 'true'" ++ forKey
Just JFalse -> Left $ "Expected an object, got 'false'" ++ forKey
Just JNull -> Left $ "Expected an object, got 'null'" ++ forKey
where forKey = " for key 'source'"
getStringOrStringList :: Bool -> String -> String
-> ([String] -> Either String a)
-> Either String a
getStringOrStringList mandatory keystr key f = case lookup key kv of
Nothing -> if mandatory
then Left $ "Mandatory field missing: '" ++ key ++ "'"
else f []
Just (JArray a) -> case stringsFromJArray keystr a of
Left e -> Left e
Right e -> f e
Just (JString s) -> f [s]
Just (JObject _) -> Left $ expectedText ++ "an object" ++ forKey
Just (JNumber _) -> Left $ expectedText ++ "a number" ++ forKey
Just JTrue -> Left $ expectedText ++ "'true'" ++ forKey
Just JFalse -> Left $ expectedText ++ "'false'" ++ forKey
Just JNull -> Left $ expectedText ++ "'null'" ++ forKey
where
forKey = " for key '" ++ key ++ "'"
expectedText = "Expected an array, got "
getElemList elemsfromarray key f = case lookup key kv of
Nothing -> f []
Just (JArray a) -> case elemsfromarray a of Left e -> Left e
Right e -> f e
Just (JObject _) -> Left $ expectedText ++ "an object" ++ forKey
Just (JString _) -> Left $ expectedText ++ "a string" ++ forKey
Just (JNumber _) -> Left $ expectedText ++ "a number" ++ forKey
Just JTrue -> Left $ expectedText ++ "'true'" ++ forKey
Just JFalse -> Left $ expectedText ++ "'false'" ++ forKey
Just JNull -> Left $ expectedText ++ "'null'" ++ forKey
where
forKey = " for key '" ++ key ++ "'"
expectedText = "Expected an array, got "
getStringList keystr = getElemList (stringsFromJArray keystr)
getExecutableSpec :: ([PackageExecutable] -> Either String a)
-> Either String a
getExecutableSpec f = case lookup "executable" kv of
Nothing -> f []
Just (JObject s) -> case execSpecFromJObject s of Left e -> Left e
Right s' -> f [s']
Just (JString _) -> Left $ "Expected an object, got a string" ++ forKey
Just (JArray _) -> Left $ "Expected an object, got an array" ++ forKey
Just (JNumber _) -> Left $ "Expected an object, got a number" ++ forKey
Just JTrue -> Left $ "Expected an object, got 'true'" ++ forKey
Just JFalse -> Left $ "Expected an object, got 'false'" ++ forKey
Just JNull -> Left $ "Expected an object, got 'null'" ++ forKey
where forKey = " for key 'executable'"
getTestSuite :: (Maybe [PackageTest] -> Either String a) -> Either String a
getTestSuite f = case lookup "testsuite" kv of
Nothing -> f Nothing
Just (JObject s) -> case testSuiteFromJObject s of
Left e -> Left e
Right s' -> f (Just [s'])
Just (JArray a) -> case testSuiteFromJArray a of
Left e -> Left e
Right s' -> f (Just s')
Just (JString _) -> Left $ "Expected an object, got a string" ++ forKey
Just (JNumber _) -> Left $ "Expected an object, got a number" ++ forKey
Just JTrue -> Left $ "Expected an object, got 'true'" ++ forKey
Just JFalse -> Left $ "Expected an object, got 'false'" ++ forKey
Just JNull -> Left $ "Expected an object, got 'null'" ++ forKey
where forKey = " for key 'testsuite'"
getDocumentationSpec :: (Maybe PackageDocumentation -> Either String a)
-> Either String a
getDocumentationSpec f = case lookup "documentation" kv of
Nothing -> f Nothing
Just (JObject s) -> case docuSpecFromJObject s of Left e -> Left e
Right s' -> f (Just s')
Just (JString _) -> Left $ "Expected an object, got a string" ++ forKey
Just (JArray _) -> Left $ "Expected an object, got an array" ++ forKey
Just (JNumber _) -> Left $ "Expected an object, got a number" ++ forKey
Just JTrue -> Left $ "Expected an object, got 'true'" ++ forKey
Just JFalse -> Left $ "Expected an object, got 'false'" ++ forKey
Just JNull -> Left $ "Expected an object, got 'null'" ++ forKey
where forKey = " for key 'documentation'"
mandatoryString :: String -> [(String, JValue)]
-> (String -> Either String a) -> Either String a
mandatoryString k kv f = case lookup k kv of
Nothing -> Left $ "Mandatory field missing: '" ++ k ++ "'"
Just (JString s) -> f s
Just (JObject _) -> Left $ "Expected a string, got an object" ++ forKey
Just (JArray _) -> Left $ "Expected a string, got an array" ++ forKey
Just (JNumber _) -> Left $ "Expected a string, got a number" ++ forKey
Just JTrue -> Left $ "Expected a string, got 'true'" ++ forKey
Just JFalse -> Left $ "Expected a string, got 'false'" ++ forKey
Just JNull -> Left $ "Expected a string, got 'null'" ++ forKey
where forKey = " for key '" ++ k ++ "'"
optionalString :: String -> [(String, JValue)]
-> (Maybe String -> Either String a) -> Either String a
optionalString k kv f = case lookup k kv of
Nothing -> f Nothing
Just (JString s) -> f (Just s)
Just (JObject _) -> Left $ "Expected a string, got an object" ++ forKey
Just (JArray _) -> Left $ "Expected a string, got an array" ++ forKey
Just (JNumber _) -> Left $ "Expected a string, got a number" ++ forKey
Just JTrue -> Left $ "Expected a string, got 'true'" ++ forKey
Just JFalse -> Left $ "Expected a string, got 'false'" ++ forKey
Just JNull -> Left $ "Expected a string, got 'null'" ++ forKey
where forKey = " for key '" ++ k ++ "'"
test_specFromJObject_mandatoryFields :: Prop
test_specFromJObject_mandatoryFields =
is (packageSpecFromJObject obj)
(\x -> isLeft x && isInfixOf "name" ((head . lefts) [x]))
where obj = [("hello", JString "world")]
test_specFromJObject_invalidVersion :: Prop
test_specFromJObject_invalidVersion =
is (packageSpecFromJObject obj)
(\x -> isLeft x && isInfixOf "version" ((head . lefts) [x]))
where obj = [ ("name", JString "mypackage"), ("author", JString "test")
, ("synopsis", JString "great!"), ("version", JString "1.2.b")]
test_specFromJObject_minimalSpec :: Prop
test_specFromJObject_minimalSpec =
is (packageSpecFromJObject obj) (\x -> isRight x && test x)
where obj = [ ("name", JString "mypackage"), ("author", JString "me")
, ("synopsis", JString "great!"), ("version", JString "1.2.3")]
test x = author p == ["me"] && name p == "mypackage"
where p = (head . rights) [x]
--- Reads a list of elements (specified by the first argument)
--- from a list of JValues.
elemsFromJArray :: (JValue -> Either String a) -> [JValue]
-> Either String [a]
elemsFromJArray readelem a =
let elems = map readelem a
in if any isLeft elems
then Left $ head $ lefts elems
else Right $ rights elems
--- Reads a list of strings from a list of JValues.
stringsFromJArray :: String -> [JValue] -> Either String [String]
stringsFromJArray ekind = elemsFromJArray extractString
where
extractString s = case s of
JString s' -> Right s'
_ -> Left $ ekind ++ " must be a string"
--- Reads the dependency constraints of a package from the key-value-pairs of a
--- JObject.
dependenciesFromJObject :: [(String, JValue)] -> Either String [Dependency]
dependenciesFromJObject kv = if any isLeft dependencies
then Left $ intercalate "; " (lefts dependencies)
else Right $ rights dependencies
where
dependencies = map buildDependency kv
buildDependency (pkg, JString vc) = case readVersionConstraints vc of
Nothing -> Left $ "Invalid constraint '" ++ vc ++ "' for package '" ++
pkg ++ "'"
Just v -> Right $ Dependency pkg v
buildDependency (_, JObject _) = wrongVersionConstraint
buildDependency (_, JArray _) = wrongVersionConstraint
buildDependency (_, JNumber _) = wrongVersionConstraint
buildDependency (_, JTrue ) = wrongVersionConstraint
buildDependency (_, JFalse ) = wrongVersionConstraint
buildDependency (_, JNull ) = wrongVersionConstraint
wrongVersionConstraint = Left "Version constraint must be a string"
--- Reads the compiler compatibility constraints of a package from the
--- key-value-pairs of a JObject.
compilerCompatibilityFromJObject :: [(String, JValue)]
-> Either String [CompilerCompatibility]
compilerCompatibilityFromJObject kv = if any isLeft compilerCompats
then Left $ intercalate "; " (lefts compilerCompats)
else Right $ rights compilerCompats
where
compilerCompats = map buildCompilerCompat kv
buildCompilerCompat (c, JString vc) = case readVersionConstraints vc of
Nothing -> Left $ "Invalid constraint '" ++ vc ++ "' for compiler '" ++
c ++ "'"
Just v -> Right $ CompilerCompatibility c v
buildCompilerCompat (_, JObject _) = wrongVersionConstraint
buildCompilerCompat (_, JArray _) = wrongVersionConstraint
buildCompilerCompat (_, JNumber _) = wrongVersionConstraint
buildCompilerCompat (_, JTrue ) = wrongVersionConstraint
buildCompilerCompat (_, JFalse ) = wrongVersionConstraint
buildCompilerCompat (_, JNull ) = wrongVersionConstraint
wrongVersionConstraint = Left "Version constraint must be a string"
--- Read source specification from the key-value-pairs of a JObject.
sourceFromJObject :: [(String, JValue)] -> Either String PackageSource
sourceFromJObject kv = case lookup "http" kv of
Nothing -> case lookup "git" kv of
Nothing -> Left $ "Only Git and HTTP supported"
Just (JString url) -> case revisionFromJObject kv of
Left err -> Left err
Right rev -> Right $ Git url rev
Just _ -> Left "Git expects url"
Just (JString url) -> Right $ Http url
Just _ -> Left "HTTP expects url"
--- Read Git revision specification from the key-value-pairs of a JObject.
revisionFromJObject :: [(String, JValue)] -> Either String (Maybe GitRevision)
revisionFromJObject kv = case lookup "tag" kv of
Nothing -> case lookup "ref" kv of
Nothing -> Right Nothing
Just (JString ref) -> Right $ Just $ Ref ref
Just _ -> Left "Ref expects string"
Just (JString tag) -> if tag == "$version"
then Right $ Just $ VersionAsTag
else Right $ Just $ Tag tag
Just _ -> Left "Tag expects string"
--- Reads an executable specification from a list of JValue (a testsuite object).
execSpecFromJValue :: JValue -> Either String PackageExecutable
execSpecFromJValue s = case s of
JObject o -> execSpecFromJObject o
_ -> Left "Array element must be a executable object"
--- Reads executable specification from the key-value-pairs of a JObject.
execSpecFromJObject :: [(String, JValue)] -> Either String PackageExecutable
execSpecFromJObject kv =
mandatoryString "name" kv $ \name ->
optionalString "main" kv $ \main ->
case lookup "options" kv of
Nothing -> Right $ PackageExecutable name (maybe "Main" id main) []
Just (JObject o) -> case optionsFromObject o of
Left e -> Left e
Right os -> Right $ PackageExecutable name (maybe "Main" id main) os
Just _ -> Left "Expected an object for 'executable>options'"
where
optionsFromObject o =
let os = map (extractString . snd) o
in if any isLeft os
then Left $ head (lefts os)
else Right (zip (map fst o) (map fromRight os))
extractString s = case s of
JString s' -> Right s'
_ -> Left $ "'executable>options': values must be strings"
--- Reads the list of testsuites from a list of JValues (testsuite objects).
testSuiteFromJArray :: [JValue] -> Either String [PackageTest]
testSuiteFromJArray = elemsFromJArray extractTest
where
extractTest s = case s of
JObject o -> testSuiteFromJObject o
_ -> Left "Array element must be a testsuite object"
--- Reads a test suite specification from the key-value-pairs of a JObject.
testSuiteFromJObject :: [(String, JValue)] -> Either String PackageTest
testSuiteFromJObject kv =
mandatoryString "src-dir" kv $ \dir ->
optionalString "options" kv $ \opts ->
optionalString "script" kv $ \scriptval ->
let script = maybe "" id scriptval in
case getOptStringList (not (null script)) "module" kv of
Left e -> Left e
Right mods -> if null script && null mods
then Left emptyError
else if not (null script) && not (null mods)
then Left doubleError
else Right $ PackageTest dir mods (maybe "" id opts)
script
where
emptyError = "'script' and 'modules' cannot be both empty in 'testsuite'"
doubleError = "'script' and 'modules' cannot be both non-empty in 'testsuite'"
--- Reads an (optional, if first argument = True) key with a string list value.
getOptStringList :: Bool -> String -> [(String, JValue)]
-> Either String [String]
getOptStringList optional key kv = case lookup (key++"s") kv of
Nothing -> if optional
then Right []
else Left $ "'"++key++"s' is not provided in 'testsuite'"
Just (JArray a) -> stringsFromJArray ("A "++key) a
Just (JObject _) -> Left $ expectedText ++ "an object" ++ forKey
Just (JString _) -> Left $ expectedText ++ "a string" ++ forKey
Just (JNumber _) -> Left $ expectedText ++ "a number" ++ forKey
Just JTrue -> Left $ expectedText ++ "'true'" ++ forKey
Just JFalse -> Left $ expectedText ++ "'false'" ++ forKey
Just JNull -> Left $ expectedText ++ "'null'" ++ forKey
where
forKey = " for key '" ++ key ++ "s'"
expectedText = "Expected an array, got "
--- Reads documentation specification from the key-value-pairs of a JObject.
docuSpecFromJObject :: [(String, JValue)] -> Either String PackageDocumentation
docuSpecFromJObject kv =
mandatoryString "src-dir" kv $ \docdir ->
mandatoryString "main" kv $ \docmain ->
optionalString "command" kv $ \doccmd ->
Right $ PackageDocumentation docdir docmain (maybe "" id doccmd)
--- Reads a dependency constraint expression in disjunctive normal form into
--- a list of lists of version constraints. The inner lists are conjunctions of
--- version constraints, the outer list is a disjunction of conjunctions.
readVersionConstraints :: String -> Maybe [[VersionConstraint]]
readVersionConstraints s = parse pVersionConstraints (dropWhile isSpace s)
test_readVersionConstraints_single :: Prop
test_readVersionConstraints_single = readVersionConstraints "=1.2.3" -=- Just [[VExact (1, 2, 3, Nothing)]]
test_readVersionConstraints_multi :: Prop
test_readVersionConstraints_multi = readVersionConstraints "> 1.0.0, < 2.3.0" -=- Just [[VGt (1, 0, 0, Nothing), VLt (2, 3, 0, Nothing)]]
test_readVersionConstraints_disjunction :: Prop
test_readVersionConstraints_disjunction = readVersionConstraints ">= 4.0.0 || < 3.0.0, > 2.0.0" -=- Just [[VGte (4, 0, 0, Nothing)], [VLt (3, 0, 0, Nothing), VGt (2, 0, 0, Nothing)]]
pVersionConstraints :: Parser [[VersionConstraint]]
pVersionConstraints = (:) <$> pConjunction <*> (pWhitespace *> char '|' *> char '|' *> pWhitespace *> pVersionConstraints <|> yield [])
pConjunction :: Parser [VersionConstraint]
pConjunction = (:) <$> pVersionConstraint <*> (pWhitespace *> char ',' *> pWhitespace *> pConjunction <|> yield [])
--- Parses a version constraint.
readVersionConstraint :: String -> Maybe VersionConstraint
readVersionConstraint s = parse pVersionConstraint s
test_readVersionConstraint_exact :: Prop
test_readVersionConstraint_exact = readVersionConstraint "=1.2.3" -=- (Just $ VExact (1, 2, 3, Nothing))
test_readVersionConstraint_without :: Prop
test_readVersionConstraint_without = readVersionConstraint "1.2.3" -=- (Just $ VExact (1, 2, 3, Nothing))
test_readVersionConstraint_invalidVersion :: Prop
test_readVersionConstraint_invalidVersion = readVersionConstraint "=4.a.3" -=- Nothing
test_readVersionConstraint_invalidConstraint :: Prop
test_readVersionConstraint_invalidConstraint = readVersionConstraint "x1.2.3" -=- Nothing
test_readVersionConstraint_greaterThan :: Prop
test_readVersionConstraint_greaterThan = readVersionConstraint "> 1.2.3" -=- (Just $ VGt (1, 2, 3, Nothing))
test_readVersionConstraint_greaterThanEqual :: Prop
test_readVersionConstraint_greaterThanEqual =
readVersionConstraint ">= 1.2.3" -=- (Just $ VGte (1, 2, 3, Nothing))
test_readVersionConstraint_lessThan :: Prop
test_readVersionConstraint_lessThan =
readVersionConstraint "<1.2.3" -=- (Just $ VLt (1, 2, 3, Nothing))
test_readVersionConstraint_lessThanEqual :: Prop
test_readVersionConstraint_lessThanEqual =
readVersionConstraint "<= 1.2.3" -=- (Just $ VLte (1, 2, 3, Nothing))
test_readVersionConstraint_mincompatible :: Prop
test_readVersionConstraint_mincompatible =
readVersionConstraint "~1.2.3" -=- (Just $ VMinCompatible (1, 2, 3, Nothing))
test_readVersionConstraint_majcompatible :: Prop
test_readVersionConstraint_majcompatible =
readVersionConstraint "^1.2.3" -=- (Just $ VMajCompatible (1, 2, 3, Nothing))
pVersionConstraint :: Parser VersionConstraint
pVersionConstraint = pConstraint <*> (pWhitespace *> pVersion)
pConstraint :: Parser (Version -> VersionConstraint)
pConstraint = char '=' *> yield VExact
<|> char '>' *> char '=' *> yield VGte
<|> char '>' *> yield VGt
<|> char '<' *> char '=' *> yield VLte
<|> char '<' *> yield VLt
<|> char '~' *> yield VMinCompatible
<|> char '~' *> char '>' *> yield VMinCompatible -- backward comp.
<|> char '^' *> yield VMajCompatible
<|> yield VExact
pWhitespace :: Parser ()
pWhitespace = some (char ' ') *> yield () <|> empty
--- Shows a version in dotted notation.
showVersion :: Version -> String
showVersion (maj, min, pat, pre) = majMinPat ++ preRelease
where majMinPat = intercalate "." $ map show [maj, min, pat]
preRelease = case pre of
Just specifier -> "-" ++ specifier
Nothing -> ""
--- Tries to parse a version string.
tryReadVersion :: String -> ErrorLogger Version
tryReadVersion s = case readVersion s of
Just v -> return v
Nothing -> fail $ s ++ " is not a valid version"
--- Tries to parse a version string.
readVersion :: String -> Maybe Version
readVersion s = parse pVersion s
pVersion :: Parser Version
pVersion = pPureVersion
<|> (\(maj, min, pat, _) pre -> (maj, min, pat, Just pre))
<$> pPureVersion <*> (char '-' *> pPreRelease)
pPureVersion :: Parser Version
pPureVersion = (\maj (min, pat) -> (maj, min, pat, Nothing))
<$> (pNum <* char '.') <*> ((\min pat -> (min, pat))
<$> pNum <* char '.' <*> pNum)
pPreRelease :: Parser String
pPreRelease = some (check isAscii anyChar)
pNum :: Parser Int
pNum = (\cs -> foldl1 ((+).(10*)) (map (\c' -> ord c' - ord '0') cs))
<$> some pDigit
pDigit :: Parser Char
pDigit = check isDigit anyChar
|