Commit 1658ad8b authored by ijones's avatar ijones
Browse files

cvs pull from Simon Marlow

  Clean up parsing & pretty-printing.
  
  Most list fields now have consistent syntax:
  
    - commas are optional
    - each element of the list is either
  	- a sequence of one or more non-space non-comma characters
  	- a quoted string in Haskell 98 lexical syntax
  
  The build-depends field still requires commas, because the elements
  can contain whitespace.
  
  I merged fieldGet/fieldShow in StanzaField into a single field for
  simplicity.
parent 1f074e16
......@@ -58,8 +58,8 @@ module Distribution.InstalledPackageInfo (
import Distribution.ParseUtils (
StanzaField(..), singleStanza, ParseResult(..), LineNo,
simpleField, listField, parseLicenseQ,
parseFilePathQ, parseLibNameQ, parseModuleNameQ, parsePackageNameQ,
showFilePath, parseReadS, parseOptVersion, parseQuoted,
parseFilePathQ, parseTokenQ, parseModuleNameQ, parsePackageNameQ,
showFilePath, showToken, parseReadS, parseOptVersion, parseQuoted,
showFreeText)
import Distribution.License ( License(..) )
import Distribution.Extension ( Opt )
......@@ -98,11 +98,11 @@ data InstalledPackageInfo
includeDirs :: [FilePath],
includes :: [String],
depends :: [PackageIdentifier],
extraHugsOpts :: [Opt],
extraCcOpts :: [Opt],
extraLdOpts :: [Opt],
hugsOptions :: [Opt],
ccOptions :: [Opt],
ldOptions :: [Opt],
frameworkDirs :: [FilePath],
extraFrameworks :: [String],
frameworks :: [String],
haddockInterfaces :: [FilePath],
haddockHTMLs :: [FilePath]
}
......@@ -111,31 +111,31 @@ data InstalledPackageInfo
emptyInstalledPackageInfo :: InstalledPackageInfo
emptyInstalledPackageInfo
= InstalledPackageInfo {
package = PackageIdentifier "" noVersion,
license = AllRightsReserved,
copyright = "",
maintainer = "",
author = "",
stability = "",
homepage = "",
pkgUrl = "",
description = "",
category = "",
exposed = False,
exposedModules = [],
hiddenModules = [],
importDirs = [],
libraryDirs = [],
hsLibraries = [],
extraLibraries = [],
includeDirs = [],
includes = [],
depends = [],
extraHugsOpts = [],
extraCcOpts = [],
extraLdOpts = [],
frameworkDirs = [],
extraFrameworks = [],
package = PackageIdentifier "" noVersion,
license = AllRightsReserved,
copyright = "",
maintainer = "",
author = "",
stability = "",
homepage = "",
pkgUrl = "",
description = "",
category = "",
exposed = False,
exposedModules = [],
hiddenModules = [],
importDirs = [],
libraryDirs = [],
hsLibraries = [],
extraLibraries = [],
includeDirs = [],
includes = [],
depends = [],
hugsOptions = [],
ccOptions = [],
ldOptions = [],
frameworkDirs = [],
frameworks = [],
haddockInterfaces = [],
haddockHTMLs = []
}
......@@ -157,7 +157,7 @@ parseBasicStanza :: [StanzaField a]
-> a
-> (LineNo, String, String)
-> ParseResult a
parseBasicStanza ((StanzaField name _ _ set):fields) pkg (lineNo, f, val)
parseBasicStanza ((StanzaField name _ set):fields) pkg (lineNo, f, val)
| name == f = set lineNo val pkg
| otherwise = parseBasicStanza fields pkg (lineNo, f, val)
parseBasicStanza [] pkg (_, _, _) = return pkg
......@@ -169,15 +169,18 @@ showInstalledPackageInfo :: InstalledPackageInfo -> String
showInstalledPackageInfo pkg = render (ppFields fields)
where
ppFields [] = empty
ppFields ((StanzaField _ get' _ _):flds) = get' pkg $$ ppFields flds
ppFields ((StanzaField name get' _):flds) =
pprField name (get' pkg) $$ ppFields flds
showInstalledPackageInfoField
:: String
-> Maybe (InstalledPackageInfo -> String)
showInstalledPackageInfoField field
= case [ get' | (StanzaField f get' _ _) <- fields, f == field ] of
= case [ (f,get') | (StanzaField f get' _) <- fields, f == field ] of
[] -> Nothing
(get':_) -> Just (render . get')
((f,get'):_) -> Just (render . pprField f . get')
pprField name field = text name <> colon <+> field
-- -----------------------------------------------------------------------------
-- Description of the fields, for parsing/printing
......@@ -240,10 +243,10 @@ installedStanzaFields = [
showFilePath parseFilePathQ
libraryDirs (\xs pkg -> pkg{libraryDirs=xs})
, listField "hs-libraries"
showFilePath parseLibNameQ
showFilePath parseTokenQ
hsLibraries (\xs pkg -> pkg{hsLibraries=xs})
, listField "extra-libs"
text parseLibNameQ
, listField "extra-libraries"
showToken parseTokenQ
extraLibraries (\xs pkg -> pkg{extraLibraries=xs})
, listField "include-dirs"
showFilePath parseFilePathQ
......@@ -254,21 +257,21 @@ installedStanzaFields = [
, listField "depends"
(text.showPackageId) parsePackageId'
depends (\xs pkg -> pkg{depends=xs})
, listField "extra-hugs-opts"
text parseFilePathQ
extraHugsOpts (\path pkg -> pkg{extraHugsOpts=path})
, listField "extra-cc-opts"
text parseFilePathQ
extraCcOpts (\path pkg -> pkg{extraCcOpts=path})
, listField "extra-ld-opts"
text parseFilePathQ
extraLdOpts (\path pkg -> pkg{extraLdOpts=path})
, listField "hugs-options"
showToken parseTokenQ
hugsOptions (\path pkg -> pkg{hugsOptions=path})
, listField "cc-options"
showToken parseTokenQ
ccOptions (\path pkg -> pkg{ccOptions=path})
, listField "ld-options"
showToken parseTokenQ
ldOptions (\path pkg -> pkg{ldOptions=path})
, listField "framework-dirs"
showFilePath parseFilePathQ
frameworkDirs (\xs pkg -> pkg{frameworkDirs=xs})
, listField "extra-frameworks"
showFilePath parseFilePathQ
extraFrameworks (\xs pkg -> pkg{extraFrameworks=xs})
, listField "frameworks"
showToken parseTokenQ
frameworks (\xs pkg -> pkg{frameworks=xs})
, listField "haddock-interfaces"
showFilePath parseFilePathQ
haddockInterfaces (\xs pkg -> pkg{haddockInterfaces=xs})
......
......@@ -81,7 +81,7 @@ module Distribution.PackageDescription (
import Control.Monad(liftM, foldM, when)
import Data.Char
import Data.Maybe(fromMaybe, fromJust, isNothing)
import Text.PrettyPrint.HughesPJ(text, render, ($$), (<+>), empty, space, vcat, fsep)
import Text.PrettyPrint.HughesPJ
import System.Directory(doesFileExist)
import Distribution.ParseUtils
......@@ -331,7 +331,7 @@ basicStanzaFields =
, simpleField "maintainer"
showFreeText (munch (const True))
maintainer (\val pkg -> pkg{maintainer=val})
, listField "build-depends"
, commaListField "build-depends"
showDependency parseDependency
buildDepends (\xs pkg -> pkg{buildDepends=xs})
, simpleField "stability"
......@@ -381,14 +381,14 @@ binfoFields =
[ simpleField "buildable"
(text . show) parseReadS
buildable (\val binfo -> binfo{buildable=val})
, simpleField "cc-options"
(fsep . map text) (fmap words (munch (const True)))
, listField "cc-options"
showToken parseTokenQ
ccOptions (\val binfo -> binfo{ccOptions=val})
, simpleField "ld-options"
(fsep . map text) (fmap words (munch (const True)))
, listField "ld-options"
showToken parseTokenQ
ldOptions (\val binfo -> binfo{ldOptions=val})
, simpleField "frameworks"
(fsep . map text) (fmap words (munch (const True)))
, listField "frameworks"
showToken parseTokenQ
frameworks (\val binfo -> binfo{frameworks=val})
, listField "c-sources"
showFilePath parseFilePathQ
......@@ -397,10 +397,10 @@ binfoFields =
(text . show) parseExtensionQ
extensions (\exts binfo -> binfo{extensions=exts})
, listField "extra-libs"
text parseLibNameQ
showToken parseTokenQ
extraLibs (\xs binfo -> binfo{extraLibs=xs})
, listField "extra-lib-dirs"
text parseLibNameQ
showFilePath parseFilePathQ
extraLibDirs (\xs binfo -> binfo{extraLibDirs=xs})
, listField "includes"
showFilePath parseFilePathQ
......@@ -449,7 +449,7 @@ parseDescription inp = do (st:sts) <- splitStanzas inp
exes <- mapM parseExecutableStanza sts
return pkg{executables=exes}
where -- The basic stanza, with library building info
parseBasicStanza ((StanzaField name _ _ set):fields) pkg (lineNo, f, val)
parseBasicStanza ((StanzaField name _ set):fields) pkg (lineNo, f, val)
| name == f = set lineNo val pkg
| otherwise = parseBasicStanza fields pkg (lineNo, f, val)
parseBasicStanza [] pkg (lineNo, f, val) = do
......@@ -465,7 +465,7 @@ parseDescription inp = do (st:sts) <- splitStanzas inp
myError lineNo $ "'Executable' stanza starting with field '" ++ f ++ "'"
parseExecutableStanza _ = error "This shouldn't happen!"
parseExecutableField ((StanzaField name _ _ set):fields) exe (lineNo, f, val)
parseExecutableField ((StanzaField name _ set):fields) exe (lineNo, f, val)
| name == f = set lineNo val exe
| otherwise = parseExecutableField fields exe (lineNo, f, val)
parseExecutableField [] exe (lineNo, f, val) = do
......@@ -505,7 +505,7 @@ parseHookedBuildInfo inp = do
parseBI st = foldM (parseBInfoField binfoFields) emptyBuildInfo st
parseBInfoField :: [StanzaField a] -> a -> (LineNo, String, String) -> ParseResult a
parseBInfoField ((StanzaField name _ _ set):fields) binfo (lineNo, f, val)
parseBInfoField ((StanzaField name _ set):fields) binfo (lineNo, f, val)
| name == f = set lineNo val binfo
| otherwise = parseBInfoField fields binfo (lineNo, f, val)
parseBInfoField [] _ (lineNo, f, _) =
......@@ -531,8 +531,10 @@ showPackageDescription pkg = render $
ppFields (buildInfo exe) binfoFields
ppFields _ [] = empty
ppFields pkg' ((StanzaField _ get _ _):flds) =
get pkg' $$ ppFields pkg' flds
ppFields pkg' ((StanzaField name get _):flds) =
ppField name (get pkg') $$ ppFields pkg' flds
ppField name field = text name <> colon <+> field
writeHookedBuildInfo :: FilePath -> HookedBuildInfo -> IO ()
writeHookedBuildInfo fpath pbi = writeFile fpath (showHookedBuildInfo pbi)
......@@ -550,8 +552,8 @@ showHookedBuildInfo (mb_lib_bi, ex_bi) = render $
ppFields bi binfoFields
ppFields _ [] = empty
ppFields bi ((StanzaField _ get _ _):flds) =
get bi $$ ppFields bi flds
ppFields bi ((StanzaField name get _):flds) =
ppField name (get bi) $$ ppFields bi flds
-- ------------------------------------------------------------
......
......@@ -47,12 +47,12 @@ module Distribution.ParseUtils (
LineNo, PError(..), showError, myError, runP,
ParseResult(..),
StanzaField(..), splitStanzas, Stanza, singleStanza,
parseFilePathQ, parseLibNameQ,
parseFilePathQ, parseTokenQ,
parseModuleNameQ, parseDependency, parseOptVersion,
parsePackageNameQ, parseVersionRangeQ,
parseTestedWithQ, parseLicenseQ, parseExtensionQ, parseCommaList,
showFilePath, showTestedWith, showDependency, showFreeText,
simpleField, listField, optsField,
showFilePath, showToken, showTestedWith, showDependency, showFreeText,
simpleField, listField, commaListField, optsField,
parseReadS, parseQuoted,
) where
......@@ -107,40 +107,35 @@ myError n s = ParseFailed $ FromString s (Just n)
data StanzaField a
= StanzaField
{ fieldName :: String
, fieldShow :: a -> Doc
, fieldGet :: a -> Doc
, fieldSet :: LineNo -> String -> a -> ParseResult a
}
simpleField :: String -> (a -> Doc) -> (ReadP a a) -> (b -> a) -> (a -> b -> b) -> StanzaField b
simpleField name showF readF get set = StanzaField name
(\st -> text name <> colon <+> showF (get st))
(showF . get)
(\st -> showF (get st))
(\lineNo val st -> do
x <- runP lineNo name readF val
return (set x st))
commaListField :: String -> (a -> Doc) -> (ReadP [a] a) -> (b -> [a]) -> ([a] -> b -> b) -> StanzaField b
commaListField name showF readF get set = StanzaField name
(\st -> fsep (punctuate comma (map showF (get st))))
(\lineNo val st -> do
xs <- runP lineNo name (parseCommaList readF) val
return (set xs st))
listField :: String -> (a -> Doc) -> (ReadP [a] a) -> (b -> [a]) -> ([a] -> b -> b) -> StanzaField b
listField name showF readF get set = StanzaField name
(\st -> case get st of
[] -> empty
lst ->
text name <> colon <+> fsep (punctuate comma (map showF lst)))
(\st -> case get st of
[] -> empty
lst ->
vcat (map (\value -> comma <+> showF value) lst))
(\st -> fsep (map showF (get st)))
(\lineNo val st -> do
xs <- runP lineNo name (parseCommaList readF) val
xs <- runP lineNo name (parseOptCommaList readF) val
return (set xs st))
optsField :: String -> CompilerFlavor -> (b -> [(CompilerFlavor,[String])]) -> ([(CompilerFlavor,[String])] -> b -> b) -> StanzaField b
optsField name flavor get set = StanzaField name
(\st -> case lookup flavor (get st) of
Just args -> text name <> colon <+> hsep (map text args)
Nothing -> empty)
(\st -> case lookup flavor (get st) of
Just args -> sep (map text args)
Just args -> hsep (map text args)
Nothing -> empty)
(\_ val st ->
let
......@@ -211,7 +206,7 @@ parseModuleNameQ = parseQuoted modu <++ modu
return (c:cs)
parseFilePathQ :: ReadP r FilePath
parseFilePathQ = parseReadS <++ (munch1 (\x -> isAlphaNum x || x `elem` "-+/_."))
parseFilePathQ = parseTokenQ
parseReadS :: Read a => ReadP r a
parseReadS = readS_to_P reads
......@@ -253,14 +248,19 @@ parseLicenseQ = parseQuoted parseReadS <++ parseReadS
parseExtensionQ :: ReadP r Extension
parseExtensionQ = parseQuoted parseReadS <++ parseReadS
parseLibNameQ :: ReadP r String
parseLibNameQ = parseReadS <++ munch1 (\x -> not (isSpace x) && x /= ',')
parseTokenQ :: ReadP r String
parseTokenQ = parseReadS <++ munch1 (\x -> not (isSpace x) && x /= ',')
parseCommaList :: ReadP r a -- ^The parser for the stuff between commas
-> ReadP r [a]
parseCommaList p = sepBy p separator
where separator = skipSpaces >> ReadP.char ',' >> skipSpaces
parseOptCommaList :: ReadP r a -- ^The parser for the stuff between commas
-> ReadP r [a]
parseOptCommaList p = sepBy p separator
where separator = skipSpaces >> optional (ReadP.char ',') >> skipSpaces
parseQuoted :: ReadP r a -> ReadP r a
parseQuoted p = between (ReadP.char '"') (ReadP.char '"') p
......@@ -268,13 +268,13 @@ parseQuoted p = between (ReadP.char '"') (ReadP.char '"') p
-- ** Pretty printing
showFilePath :: FilePath -> Doc
showFilePath fpath
| all (\x -> isAlphaNum x || x `elem` "-+/_.") fpath = text (replaceSlash fpath)
| otherwise = doubleQuotes (text (replaceSlash fpath))
where
replaceSlash s = case break (== '\\') s of
(a, (h:t)) -> a ++ (h:h:(replaceSlash t))
(a, []) -> a
showFilePath = showToken
showToken :: String -> Doc
showToken str
| not (any dodgy str) = text str
| otherwise = text (show str)
where dodgy c = isSpace c || c == ','
showTestedWith :: (CompilerFlavor,VersionRange) -> Doc
showTestedWith (compiler,version) = text (show compiler ++ " " ++ showVersionRange version)
......
......@@ -156,13 +156,10 @@ installHugs verbose libPref binPref targetLibPref buildPref pkg_descr = do
let targetDir = progTargetDir `joinFileName` exeName exe
try $ removeDirectoryRecursive installDir
smartCopySources verbose buildDir installDir
(otherModules (buildInfo exe)) hugsInstallSuffixes
let fname = hugsMainFilename exe
copyFileVerbose verbose (buildDir `joinFileName` fname)
(installDir `joinFileName` fname)
("Main" : otherModules (buildInfo exe)) hugsInstallSuffixes
#ifndef mingw32_TARGET_OS
-- FIX (HUGS): works for Unix only
let targetName = targetDir `joinFileName` fname
let targetName = targetDir `joinFileName` hugsMainFilename exe
let exeFile = binPref `joinFileName` exeName exe
-- FIX (HUGS): use extensions, and options from file too?
let hugsOptions = hcOptions Hugs (options (buildInfo exe))
......
......@@ -70,9 +70,10 @@ import Distribution.Simple.Install (hugsPackageDir)
import Distribution.Simple.GHCPackageConfig (mkGHCPackageConfig, showGHCPackageConfig)
import qualified Distribution.Simple.GHCPackageConfig
as GHC (localPackageConfig, canWriteLocalPackageConfig, maybeCreateLocalPackageConfig)
import Distribution.Compat.Directory (createDirectoryIfMissing,removeDirectoryRecursive,
setPermissions, getPermissions, executable
)
import Distribution.Compat.Directory
(createDirectoryIfMissing,removeDirectoryRecursive,
setPermissions, getPermissions, Permissions(executable)
)
import Distribution.Compat.FilePath (joinFileName)
import System.Directory(doesFileExist, removeFile)
......@@ -217,14 +218,14 @@ mkInstalledPackageInfo pkg_descr lbi
IPI.includeDirs = includeDirs bi,
IPI.includes = includes bi,
IPI.depends = packageDeps lbi,
IPI.extraHugsOpts = concat [opts | (Hugs,opts) <- options bi],
IPI.extraCcOpts = ccOptions bi,
IPI.extraLdOpts = ldOptions bi,
IPI.hugsOptions = concat [opts | (Hugs,opts) <- options bi],
IPI.ccOptions = ccOptions bi,
IPI.ldOptions = ldOptions bi,
IPI.frameworkDirs = [],
IPI.extraFrameworks = frameworks bi,
IPI.frameworks = frameworks bi,
IPI.haddockInterfaces = [],
IPI.haddockHTMLs = []
}
}
-- -----------------------------------------------------------------------------
-- Unregistration
......
......@@ -440,9 +440,9 @@ Other-Modules: A, C, Utils</programlisting>
<literal>main-is:</literal> <replaceable>filename</replaceable>
</term>
<listitem>
<para>The name of the source file containing the main module,
relative to the <literal>hs-sources</literal> directory
(required).</para>
<para>The name of the source file containing the
<literal>Main</literal> module, relative to the
<literal>hs-source-dir</literal> directory (required).</para>
</listitem>
</varlistentry>
</variablelist>
......@@ -878,12 +878,12 @@ main = defaultMain</programlisting>
runhaskell Setup.hs configure --ghc
runhaskell Setup.hs build
runhaskell Setup.hs install</screen>
<para>The first line readies the system to build the tool using GHC;
for example, it checks that GHC exists on the system. The second
line performs the actual building, while the last both copies
the build results to some permanent place and registers the
package with GHC.</para>
</example>
<para>The first line readies the system to build the tool using GHC;
for example, it checks that GHC exists on the system. The second
line performs the actual building, while the last both copies the
build results to some permanent place and registers the package
with GHC.</para>
<example>
<title>Building and installing a user package</title>
......@@ -906,11 +906,19 @@ runhaskell Setup.hs configure --ghc --prefix=/usr
runhaskell Setup.hs build
runhaskell Setup.hs copy --copy-prefix=/tmp/mypkg/usr
(cd /tmp/mypkg; tar cf - .) | gzip -9 >mypkg.tar.gz</screen>
<para>After unpacking on the target system, the package must be
registered:</para>
<screen>runhaskell Setup.lhs register</screen>
<para>A similar procedure would be needed for creating Windows
installer packages.</para>
<para>If the package contains a library, you need two additional
steps:</para>
<screen>
runhaskell Setup.hs register --gen-script
runhaskell Setup.hs unregister --gen-script</screen>
<para>This creates shell scripts <filename>register.sh</filename>
and <filename>unregister.sh</filename>, which must also be sent
to the target system. After unpacking there, the package must be
registered by running the <filename>register.sh</filename> script.
The <filename>unregister.sh</filename> script would be used
in the uninstall procedure of the package. There is not yet a
similar procedure for creating Windows installer packages.</para>
</example>
<para>The following options are understood by all commands:</para>
......@@ -1151,6 +1159,17 @@ runhaskell Setup.hs copy --copy-prefix=/tmp/mypkg/usr
database.</para>
</listitem>
</varlistentry>
<varlistentry>
<term><option>--gen-script</option></term>
<listitem>
<para>Instead of registering the package, generate a script
<filename>register.sh</filename> containing commands to
perform the register step. This file might be included
in a binary bundle, to be run after the bundle is unpacked
on the target system.</para>
</listitem>
</varlistentry>
</variablelist>
</section>
......@@ -1176,6 +1195,16 @@ runhaskell Setup.hs copy --copy-prefix=/tmp/mypkg/usr
database.</para>
</listitem>
</varlistentry>
<varlistentry>
<term><option>--gen-script</option></term>
<listitem>
<para>Instead of deregistering the package, generate a script
<filename>unregister.sh</filename> containing commands to
perform the unregister step. This file might be included
in a binary bundle, to be run on the target system.</para>
</listitem>
</varlistentry>
</variablelist>
</section>
......@@ -1187,15 +1216,60 @@ runhaskell Setup.hs copy --copy-prefix=/tmp/mypkg/usr
<section>
<title>setup sdist</title>
<para>This command is intended to create a system- and
compiler-independent source distribution, but it's not working
yet.</para>
<para>The plan is to produce a file
<para>Create a system- and compiler-independent source distribution
in a file
<filename><replaceable>package</replaceable>-<replaceable>version</replaceable>.tgz</filename>
which can be distributed to package builders. When unpacked,
that can be distributed to package builders. When unpacked,
the commands listed in this section will be available.</para>
<para>However this command is not yet working in the simple build
infrastructure.</para>
</section>
</section>
<section id="bugs">
<title>Known bugs and deficiencies</title>
<para>All these should be fixed in future versions:</para>
<itemizedlist>
<listitem>
<para>In the simple build infrastructure, the
<literal>sdist</literal> command does not work.</para>
</listitem>
<listitem>
<para>Cabal has some limitations both running under Hugs
and building packages for it:</para>
<itemizedlist>
<listitem>
<para>Cabal does not work with the current stable release
(Nov 2003), just the development version.</para>
</listitem>
<listitem>
<para>It doesn't work with Windows.</para>
</listitem>
<listitem>
<para>The <option>--user</option> option is unavailable.</para>
</listitem>
<listitem>
<para>There is no <literal>hugs-pkg</literal> tool.</para>
</listitem>
</itemizedlist>
</listitem>
<listitem>
<para>Though the library runs under Nhc98, it cannot build
packages for Nhc98.</para>
</listitem>
</itemizedlist>
<para>Please report any other flaws to
<email>libraries@haskell.org</email>.</para>
</section>
</article>
......@@ -39,7 +39,7 @@ hidden-modules:
import-dirs: IMPORT_DIR
library-dirs: LIB_DIR
hs-libraries: "HSCabal"
extra-libs:
extra-libraries:
#if defined(mingw32_HOST_OS) || defined(__MINGW32__) || defined(_MSC_VER)
"shell32"
#endif
......@@ -47,10 +47,10 @@ extra-libs:
include-dirs:
includes:
depends: base
extra-hugs-opts: