Cabal-2.0.0.2: Distribution/PackageDescription/Parsec.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleContexts #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.PackageDescription.Parsec
-- Copyright : Isaac Jones 2003-2005
-- License : BSD3
--
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
--
-- This defined parsers and partial pretty printers for the @.cabal@ format.
module Distribution.PackageDescription.Parsec (
-- * Package descriptions
readGenericPackageDescription,
parseGenericPackageDescription,
parseGenericPackageDescriptionMaybe,
-- ** Parsing
ParseResult,
runParseResult,
-- ** Supplementary build information
-- readHookedBuildInfo,
-- parseHookedBuildInfo,
) where
import Prelude ()
import Distribution.Compat.Prelude
import qualified Data.ByteString as BS
import Data.List (partition)
import qualified Data.Map as Map
import qualified Distribution.Compat.SnocList as SnocList
import Distribution.PackageDescription
import Distribution.PackageDescription.Parsec.FieldDescr
import Distribution.Parsec.Class (parsec)
import Distribution.Parsec.ConfVar
(parseConditionConfVar)
import Distribution.Parsec.LexerMonad
(LexWarning, toPWarning)
import Distribution.Parsec.Parser
import Distribution.Parsec.Types.Common
import Distribution.Parsec.Types.Field (getName)
import Distribution.Parsec.Types.FieldDescr
import Distribution.Parsec.Types.ParseResult
import Distribution.Simple.Utils
(die', fromUTF8BS, warn)
import Distribution.Text (display)
import Distribution.Types.ForeignLib
import Distribution.Types.CondTree
import Distribution.Types.UnqualComponentName
(UnqualComponentName, mkUnqualComponentName)
import Distribution.Verbosity (Verbosity)
import Distribution.Version
(LowerBound (..), Version, asVersionIntervals, mkVersion,
orLaterVersion)
import System.Directory
(doesFileExist)
import qualified Text.Parsec as P
import qualified Text.Parsec.Error as P
-- ---------------------------------------------------------------
-- Parsing
-- | Helper combinator to do parsing plumbing for files.
--
-- Given a parser and a filename, return the parse of the file,
-- after checking if the file exists.
--
-- Argument order is chosen to encourage partial application.
readAndParseFile
:: (BS.ByteString -> ParseResult a) -- ^ File contents to final value parser
-> Verbosity -- ^ Verbosity level
-> FilePath -- ^ File to read
-> IO a
readAndParseFile parser verbosity fpath = do
exists <- doesFileExist fpath
unless exists $
die' verbosity $
"Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue."
bs <- BS.readFile fpath
let (warnings, errors, result) = runParseResult (parser bs)
traverse_ (warn verbosity . showPWarning fpath) warnings
traverse_ (warn verbosity . showPError fpath) errors
case result of
Nothing -> die' verbosity $ "Failing parsing \"" ++ fpath ++ "\"."
Just x -> return x
-- | Parse the given package file.
readGenericPackageDescription :: Verbosity -> FilePath -> IO GenericPackageDescription
readGenericPackageDescription = readAndParseFile parseGenericPackageDescription
------------------------------------------------------------------------------
-- | Parses the given file into a 'GenericPackageDescription'.
--
-- In Cabal 1.2 the syntax for package descriptions was changed to a format
-- with sections and possibly indented property descriptions.
--
-- TODO: add lex warnings
parseGenericPackageDescription :: BS.ByteString -> ParseResult GenericPackageDescription
parseGenericPackageDescription bs = case readFields' bs of
Right (fs, lexWarnings) -> parseGenericPackageDescription' lexWarnings fs
-- TODO: better marshalling of errors
Left perr -> parseFatalFailure (Position 0 0) (show perr)
-- | 'Maybe' variant of 'parseGenericPackageDescription'
parseGenericPackageDescriptionMaybe :: BS.ByteString -> Maybe GenericPackageDescription
parseGenericPackageDescriptionMaybe =
trdOf3 . runParseResult . parseGenericPackageDescription
where
trdOf3 (_, _, x) = x
runFieldParser :: FieldParser a -> [FieldLine Position] -> ParseResult a
runFieldParser p ls = runFieldParser' pos p =<< fieldlinesToString pos ls
where
-- TODO: make per line lookup
pos = case ls of
[] -> Position 0 0
(FieldLine pos' _ : _) -> pos'
fieldlinesToBS :: [FieldLine ann] -> BS.ByteString
fieldlinesToBS = BS.intercalate "\n" . map (\(FieldLine _ bs) -> bs)
-- TODO: Take position from FieldLine
-- TODO: Take field name
fieldlinesToString :: Position -> [FieldLine ann] -> ParseResult String
fieldlinesToString pos fls =
let str = intercalate "\n" . map (\(FieldLine _ bs') -> fromUTF8BS bs') $ fls
in if '\xfffd' `elem` str
then str <$ parseWarning pos PWTUTF "Invalid UTF8 encoding"
else pure str
runFieldParser' :: Position -> FieldParser a -> String -> ParseResult a
runFieldParser' (Position row col) p str = case P.runParser p' [] "<field>" str of
Right (pok, ws) -> do
-- TODO: map pos
traverse_ (\(PWarning t pos w) -> parseWarning pos t w) ws
pure pok
Left err -> do
let ppos = P.errorPos err
-- Positions start from 1:1, not 0:0
let epos = Position (row - 1 + P.sourceLine ppos) (col - 1 + P.sourceColumn ppos)
let msg = P.showErrorMessages
"or" "unknown parse error" "expecting" "unexpected" "end of input"
(P.errorMessages err)
parseFatalFailure epos $ msg ++ ": " ++ show str
where
p' = (,) <$ P.spaces <*> p <* P.spaces <* P.eof <*> P.getState
-- Note [Accumulating parser]
--
-- This parser has two "states":
-- * first we parse fields of PackageDescription
-- * then we parse sections (libraries, executables, etc)
parseGenericPackageDescription'
:: [LexWarning]
-> [Field Position]
-> ParseResult GenericPackageDescription
parseGenericPackageDescription' lexWarnings fs = do
parseWarnings' (fmap toPWarning lexWarnings)
let (syntax, fs') = sectionizeFields fs
gpd <- goFields emptyGpd fs'
-- Various post checks
maybeWarnCabalVersion syntax (packageDescription gpd)
checkForUndefinedFlags gpd
-- TODO: do other validations
return gpd
where
-- First fields
goFields
:: GenericPackageDescription
-> [Field Position]
-> ParseResult GenericPackageDescription
goFields gpd [] = pure gpd
goFields gpd (Field (Name pos name) fieldLines : fields) =
case Map.lookup name pdFieldParsers of
-- TODO: can be more elegant
Nothing -> fieldlinesToString pos fieldLines >>= \value -> case storeXFieldsPD name value (packageDescription gpd) of
Nothing -> do
parseWarning pos PWTUnknownField $ "Unknown field: " ++ show name
goFields gpd fields
Just pd ->
goFields (gpd { packageDescription = pd }) fields
Just parser -> do
pd <- runFieldParser (parser $ packageDescription gpd) fieldLines
let gpd' = gpd { packageDescription = pd }
goFields gpd' fields
goFields gpd fields@(Section _ _ _ : _) = goSections gpd fields
-- Sections
goSections
:: GenericPackageDescription
-> [Field Position]
-> ParseResult GenericPackageDescription
goSections gpd [] = pure gpd
goSections gpd (Field (Name pos name) _ : fields) = do
parseWarning pos PWTTrailingFields $ "Ignoring trailing fields after sections: " ++ show name
goSections gpd fields
goSections gpd (Section name args secFields : fields) = do
gpd' <- parseSection gpd name args secFields
goSections gpd' fields
emptyGpd :: GenericPackageDescription
emptyGpd = GenericPackageDescription emptyPackageDescription [] Nothing [] [] [] [] []
pdFieldParsers :: Map FieldName (PackageDescription -> FieldParser PackageDescription)
pdFieldParsers = Map.fromList $
map (\x -> (fieldName x, fieldParser x)) pkgDescrFieldDescrs
parseSection
:: GenericPackageDescription
-> Name Position
-> [SectionArg Position]
-> [Field Position]
-> ParseResult GenericPackageDescription
parseSection gpd (Name pos name) args fields
| name == "library" && null args = do
-- TODO: check that library is defined once
l <- parseCondTree libFieldDescrs storeXFieldsLib (targetBuildDepends . libBuildInfo) emptyLibrary fields
let gpd' = gpd { condLibrary = Just l }
pure gpd'
-- Sublibraries
| name == "library" = do
name' <- parseUnqualComponentName pos args
lib <- parseCondTree libFieldDescrs storeXFieldsLib (targetBuildDepends . libBuildInfo) emptyLibrary fields
-- TODO check duplicate name here?
let gpd' = gpd { condSubLibraries = condSubLibraries gpd ++ [(name', lib)] }
pure gpd'
| name == "foreign-library" = do
name' <- parseUnqualComponentName pos args
flib <- parseCondTree foreignLibFieldDescrs storeXFieldsForeignLib (targetBuildDepends . foreignLibBuildInfo) emptyForeignLib fields
-- TODO check duplicate name here?
let gpd' = gpd { condForeignLibs = condForeignLibs gpd ++ [(name', flib)] }
pure gpd'
| name == "executable" = do
name' <- parseUnqualComponentName pos args
-- Note: we don't parse the "executable" field here, hence the tail hack. Duncan 2010
exe <- parseCondTree (tail executableFieldDescrs) storeXFieldsExe (targetBuildDepends . buildInfo) emptyExecutable fields
-- TODO check duplicate name here?
let gpd' = gpd { condExecutables = condExecutables gpd ++ [(name', exe)] }
pure gpd'
| name == "test-suite" = do
name' <- parseUnqualComponentName pos args
testStanza <- parseCondTree testSuiteFieldDescrs storeXFieldsTest (targetBuildDepends . testStanzaBuildInfo) emptyTestStanza fields
testSuite <- traverse (validateTestSuite pos) testStanza
-- TODO check duplicate name here?
let gpd' = gpd { condTestSuites = condTestSuites gpd ++ [(name', testSuite)] }
pure gpd'
| name == "benchmark" = do
name' <- parseUnqualComponentName pos args
benchStanza <- parseCondTree benchmarkFieldDescrs storeXFieldsBenchmark (targetBuildDepends . benchmarkStanzaBuildInfo) emptyBenchmarkStanza fields
bench <- traverse (validateBenchmark pos) benchStanza
-- TODO check duplicate name here?
let gpd' = gpd { condBenchmarks = condBenchmarks gpd ++ [(name', bench)] }
pure gpd'
| name == "flag" = do
name' <- parseName pos args
name'' <- runFieldParser' pos parsec name' `recoverWith` mkFlagName ""
flag <- parseFields flagFieldDescrs warnUnrec (emptyFlag name'') fields
-- Check default flag
let gpd' = gpd { genPackageFlags = genPackageFlags gpd ++ [flag] }
pure gpd'
| name == "custom-setup" && null args = do
sbi <- parseFields setupBInfoFieldDescrs warnUnrec mempty fields
let pd = packageDescription gpd
-- TODO: what if already defined?
let gpd' = gpd { packageDescription = pd { setupBuildInfo = Just sbi } }
pure gpd'
| name == "source-repository" = do
kind <- case args of
[SecArgName spos secName] ->
runFieldParser' spos parsec (fromUTF8BS secName) `recoverWith` RepoHead
[] -> do
parseFailure pos $ "'source-repository' needs one argument"
pure RepoHead
_ -> do
parseFailure pos $ "Invalid source-repository kind " ++ show args
pure RepoHead
sr <- parseFields sourceRepoFieldDescrs warnUnrec (emptySourceRepo kind) fields
-- I want lens
let pd = packageDescription gpd
let srs = sourceRepos pd
let gpd' = gpd { packageDescription = pd { sourceRepos = srs ++ [sr] } }
pure gpd'
| otherwise = do
parseWarning pos PWTUnknownSection $ "Ignoring section: " ++ show name
pure gpd
newSyntaxVersion :: Version
newSyntaxVersion = mkVersion [1, 2]
maybeWarnCabalVersion :: Syntax -> PackageDescription -> ParseResult ()
maybeWarnCabalVersion syntax pkg
| syntax == NewSyntax && specVersion pkg < newSyntaxVersion
= parseWarning (Position 0 0) PWTNewSyntax $
"A package using section syntax must specify at least\n"
++ "'cabal-version: >= 1.2'."
maybeWarnCabalVersion syntax pkg
| syntax == OldSyntax && specVersion pkg >= newSyntaxVersion
= parseWarning (Position 0 0) PWTOldSyntax $
"A package using 'cabal-version: "
++ displaySpecVersion (specVersionRaw pkg)
++ "' must use section syntax. See the Cabal user guide for details."
where
displaySpecVersion (Left version) = display version
displaySpecVersion (Right versionRange) =
case asVersionIntervals versionRange of
[] {- impossible -} -> display versionRange
((LowerBound version _, _):_) -> display (orLaterVersion version)
maybeWarnCabalVersion _ _ = return ()
{-
handleFutureVersionParseFailure :: Version -> ParseResult a -> ParseResult GenericPackageDescription
handleFutureVersionParseFailure _cabalVersionNeeded _parseBody =
error "handleFutureVersionParseFailure"
-}
{-
undefined (unless versionOk (warning message) >> parseBody)
`catchParseError` \parseError -> case parseError of
TabsError _ -> parseFail parseError
_ | versionOk -> parseFail parseError
| otherwise -> fail message
where versionOk = cabalVersionNeeded <= cabalVersion
message = "This package requires at least Cabal version "
++ display cabalVersionNeeded
-}
checkForUndefinedFlags
:: GenericPackageDescription
-> ParseResult ()
checkForUndefinedFlags _gpd = pure ()
{-
let definedFlags = map flagName flags
mapM_ (checkCondTreeFlags definedFlags) (maybeToList mlib)
mapM_ (checkCondTreeFlags definedFlags . snd) sub_libs
mapM_ (checkCondTreeFlags definedFlags . snd) exes
mapM_ (checkCondTreeFlags definedFlags . snd) tests
checkCondTreeFlags :: [FlagName] -> CondTree ConfVar c a -> PM ()
checkCondTreeFlags definedFlags ct = do
let fv = nub $ freeVars ct
unless (all (`elem` definedFlags) fv) $
fail $ "These flags are used without having been defined: "
++ intercalate ", " [ n | FlagName n <- fv \\ definedFlags ]
-}
parseName :: Position -> [SectionArg Position] -> ParseResult String
parseName pos args = case args of
[SecArgName _pos secName] ->
pure $ fromUTF8BS secName
[SecArgStr _pos secName] ->
pure secName
[] -> do
parseFailure pos $ "name required"
pure ""
_ -> do
-- TODO: pretty print args
parseFailure pos $ "Invalid name " ++ show args
pure ""
parseUnqualComponentName :: Position -> [SectionArg Position] -> ParseResult UnqualComponentName
parseUnqualComponentName pos args = mkUnqualComponentName <$> parseName pos args
-- | Parse a non-recursive list of fields, given a list of field descriptions,
-- a structure to accumulate the parsed fields, and a function
-- that can decide what to do with fields which don't match any
-- of the field descriptions.
parseFields
:: forall a.
[FieldDescr a] -- ^ descriptions of fields we know how to parse
-> UnknownFieldParser a -- ^ possibly do something with unrecognized fields
-> a -- ^ accumulator
-> [Field Position] -- ^ fields to be parsed
-> ParseResult a
parseFields descrs _unknown = foldM go
where
go :: a -> Field Position -> ParseResult a
go x (Section (Name pos name) _ _) = do
-- Even we occur a subsection, we can continue parsing
parseFailure pos $ "invalid subsection " ++ show name
return x
go x (Field (Name pos name) fieldLines) =
case Map.lookup name fieldParsers of
Nothing -> do
-- TODO: use 'unknown'
parseWarning pos PWTUnknownField $ "Unknown field: " ++ show name
return x
Just parser ->
runFieldParser (parser x) fieldLines
fieldParsers :: Map FieldName (a -> FieldParser a)
fieldParsers = Map.fromList $
map (\x -> (fieldName x, fieldParser x)) descrs
type C c a = CondBranch ConfVar c a
parseCondTree
:: forall a c.
[FieldDescr a] -- ^ Field descriptions
-> UnknownFieldParser a -- ^ How to parse unknown fields
-> (a -> c) -- ^ Condition extractor
-> a -- ^ Initial value
-> [Field Position] -- ^ Fields to parse
-> ParseResult (CondTree ConfVar c a)
parseCondTree descs unknown cond ini = impl
where
impl :: [Field Position] -> ParseResult (CondTree ConfVar c a)
impl fields = do
(x, xs) <- goFields (ini, mempty) fields
return $ CondNode x (cond x) (SnocList.runSnocList xs)
goFields
:: (a, SnocList.SnocList (C c a))
-> [Field Position]
-> ParseResult (a, SnocList.SnocList (C c a))
goFields xss [] = return xss
goFields xxs (Section (Name _pos name) tes con : fields) | name == "if" = do
tes' <- parseConditionConfVar tes
con' <- impl con
-- Jump to 'else' state
goElse tes' con' xxs fields
goFields xxs (Section (Name pos name) _ _ : fields) = do
-- Even we occur a subsection, we can continue parsing
-- http://hackage.haskell.org/package/constraints-0.1/constraints.cabal
parseWarning pos PWTInvalidSubsection $ "invalid subsection " ++ show name
goFields xxs fields
goFields (x, xs) (Field (Name pos name) fieldLines : fields) =
case Map.lookup name fieldParsers of
Nothing -> fieldlinesToString pos fieldLines >>= \value -> case unknown name value x of
Nothing -> do
parseWarning pos PWTUnknownField $ "Unknown field: " ++ show name
goFields (x, xs) fields
Just x' -> do
goFields (x', xs) fields
Just parser -> do
x' <- runFieldParser (parser x) fieldLines
goFields (x', xs) fields
-- Try to parse else branch
goElse
:: Condition ConfVar
-> CondTree ConfVar c a
-> (a, SnocList.SnocList (C c a))
-> [Field Position]
-> ParseResult (a, SnocList.SnocList (C c a))
goElse tes con (x, xs) (Section (Name pos name) secArgs alt : fields) | name == "else" = do
when (not . null $ secArgs) $ do
parseFailure pos $ "`else` section has section arguments " ++ show secArgs
alt' <- case alt of
[] -> pure Nothing
_ -> Just <$> impl alt
let ieb = (CondBranch tes con alt')
goFields (x, SnocList.snoc xs ieb) fields
goElse tes con (x, xs) fields = do
let ieb = (CondBranch tes con Nothing)
goFields (x, SnocList.snoc xs ieb) fields
fieldParsers :: Map FieldName (a -> FieldParser a)
fieldParsers = Map.fromList $
map (\x -> (fieldName x, fieldParser x)) descs
{- Note [Accumulating parser]
In there parser, @'FieldDescr' a@ is transformed into @Map FieldName (a ->
FieldParser a)@. The weird value is used because we accumulate structure of
@a@ by folding over the fields. There are various reasons for that:
* Almost all fields are optional
* This is simple approach so declarative bi-directional format (parsing and
printing) of structure could be specified (list of @'FieldDescr' a@)
* There are surface syntax fields corresponding to single field in the file:
@license-file@ and @license-files@
* This is quite safe approach.
When/if we re-implement the parser to support formatting preservging roundtrip
with new AST, this all need to be rewritten.
-}
-------------------------------------------------------------------------------
-- Old syntax
-------------------------------------------------------------------------------
-- | "Sectionize" an old-style Cabal file. A sectionized file has:
--
-- * all global fields at the beginning, followed by
--
-- * all flag declarations, followed by
--
-- * an optional library section, and an arbitrary number of executable
-- sections (in any order).
--
-- The current implementation just gathers all library-specific fields
-- in a library section and wraps all executable stanzas in an executable
-- section.
sectionizeFields :: [Field ann] -> (Syntax, [Field ann])
sectionizeFields fs = case classifyFields fs of
Just fields -> (OldSyntax, convert fields)
Nothing -> (NewSyntax, fs)
where
-- return 'Just' if all fields are simple fields
classifyFields :: [Field ann] -> Maybe [(Name ann, [FieldLine ann])]
classifyFields = traverse f
where
f (Field name fieldlines) = Just (name, fieldlines)
f _ = Nothing
trim = BS.dropWhile isSpace' . BS.reverse . BS.dropWhile isSpace' . BS.reverse
isSpace' = (== 32)
convert :: [(Name ann, [FieldLine ann])] -> [Field ann]
convert fields =
let
toField (name, ls) = Field name ls
-- "build-depends" is a local field now. To be backwards
-- compatible, we still allow it as a global field in old-style
-- package description files and translate it to a local field by
-- adding it to every non-empty section
(hdr0, exes0) = break ((=="executable") . getName . fst) fields
(hdr, libfs0) = partition (not . (`elem` libFieldNames) . getName . fst) hdr0
(deps, libfs) = partition ((== "build-depends") . getName . fst)
libfs0
exes = unfoldr toExe exes0
toExe [] = Nothing
toExe ((Name pos n, ls) : r)
| n == "executable" =
let (efs, r') = break ((== "executable") . getName . fst) r
in Just (Section (Name pos "executable") [SecArgName pos $ trim $ fieldlinesToBS ls] (map toField $ deps ++ efs), r')
toExe _ = error "unexpected input to 'toExe'"
lib = case libfs of
[] -> []
((Name pos _, _) : _) ->
[Section (Name pos "library") [] (map toField $ deps ++ libfs)]
in map toField hdr ++ lib ++ exes
-- | See 'sectionizeFields'.
data Syntax = OldSyntax | NewSyntax
deriving (Eq, Show)
libFieldNames :: [FieldName]
libFieldNames = map fieldName libFieldDescrs