Commit 51e75f3e authored by Oleg Grenrus's avatar Oleg Grenrus
Browse files

Add comments and reformat imports

parent d93fbe10
......@@ -56,7 +56,8 @@ integral = toNumber <$> some d P.<?> "integral"
f '9' = Just 9
f _ = Nothing
-- | Greedely munch characters while predicate holds.
-- | Greedily munch characters while predicate holds.
-- Require at least one character.
munch1
:: P.Stream s m Char
=> (Char -> Bool)
......@@ -64,6 +65,7 @@ munch1
munch1 = some . P.satisfy
-- | Greedely munch characters while predicate holds.
-- Always succeeds.
munch
:: P.Stream s m Char
=> (Char -> Bool)
......
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE Rank2Types #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.PackageDescription.Parsec
......@@ -27,36 +27,34 @@ module Distribution.PackageDescription.Parsec (
-- parseHookedBuildInfo,
) where
import Distribution.Compat.Prelude
import Prelude ()
import Distribution.Compat.Prelude
import qualified Data.ByteString as BS
import Data.List (partition)
import qualified Data.Map as Map
import System.Directory
(doesFileExist)
import qualified Text.Parsec as P
import qualified Text.Parsec.Error as P
import Distribution.PackageDescription
import Distribution.Simple.Utils
(die, fromUTF8BS, warn)
import Distribution.Verbosity (Verbosity)
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.Parsec.LexerMonad
(LexWarning, toPWarning)
import Distribution.Text (display)
import Distribution.Version (mkVersion, Version, asVersionIntervals, orLaterVersion, LowerBound (..))
import Distribution.Simple.Utils
(die, fromUTF8BS, warn)
import Distribution.Text (display)
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
......@@ -68,9 +66,9 @@ import Distribution.Version (mkVersion, Version, asVersionIntervals, orLaterVers
--
-- Argument order is chosen to encourage partial application.
readAndParseFile
:: (BS.ByteString -> ParseResult a)
-> Verbosity
-> FilePath
:: (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
......
......@@ -30,11 +30,8 @@ module Distribution.PackageDescription.Parsec.FieldDescr (
setupBInfoFieldDescrs,
) where
import Distribution.Compat.Prelude
import Prelude ()
import Text.PrettyPrint (vcat)
import Distribution.Compat.Prelude
import qualified Data.ByteString as BS
import Data.List (dropWhileEnd)
import qualified Distribution.Compat.Parsec as Parsec
......@@ -49,6 +46,7 @@ import Distribution.Parsec.Types.ParseResult
import Distribution.PrettyUtils
import Distribution.Simple.Utils (fromUTF8BS)
import Distribution.Text (disp, display)
import Text.PrettyPrint (vcat)
-------------------------------------------------------------------------------
-- common FieldParsers
......
......@@ -16,14 +16,12 @@ module Distribution.Parsec.Class (
parsecOptCommaList,
) where
import Distribution.Compat.Prelude
import Prelude ()
import Distribution.Compat.Prelude
import Data.Functor.Identity (Identity)
import qualified Distribution.Compat.Parsec as P
import Distribution.Parsec.Types.Common
(PWarnType (..), PWarning (..), Position (..))
import qualified Distribution.Compat.Parsec as P
import qualified Text.Parsec as Parsec
import qualified Text.Parsec.Language as Parsec
import qualified Text.Parsec.Token as Parsec
......@@ -34,6 +32,7 @@ import Distribution.Compiler
(CompilerFlavor (..), classifyCompilerFlavor)
import Distribution.License (License (..))
import Distribution.ModuleName (ModuleName)
import qualified Distribution.ModuleName as ModuleName
import Distribution.Package
(Dependency (..), PackageName, mkPackageName)
import Distribution.System
......@@ -50,13 +49,12 @@ import Distribution.Types.SourceRepo
(RepoKind, RepoType, classifyRepoKind, classifyRepoType)
import Distribution.Types.TestType (TestType (..))
import Distribution.Version
(Version, mkVersion, VersionRange (..), anyVersion, earlierVersion,
intersectVersionRanges, laterVersion, majorBoundVersion, noVersion,
orEarlierVersion, orLaterVersion, thisVersion,
unionVersionRanges, withinVersion)
(Version, VersionRange (..), anyVersion, earlierVersion,
intersectVersionRanges, laterVersion, majorBoundVersion,
mkVersion, noVersion, orEarlierVersion, orLaterVersion,
thisVersion, unionVersionRanges, withinVersion)
import Language.Haskell.Extension
(Extension, Language, classifyExtension, classifyLanguage)
import qualified Distribution.ModuleName as ModuleName
-------------------------------------------------------------------------------
-- Class
......@@ -303,6 +301,7 @@ parsecToken' = parsecHaskellString <|> (P.munch1 (not . isSpace) P.<?> "token")
parsecFilePath :: P.Stream s Identity Char => P.Parsec s [PWarning] String
parsecFilePath = parsecToken
-- | Parse a benchmark/test-suite types.
stdParse
:: P.Stream s Identity Char
=> (Version -> String -> a)
......
......@@ -2,14 +2,9 @@
{-# LANGUAGE OverloadedStrings #-}
module Distribution.Parsec.ConfVar (parseConditionConfVar) where
import Distribution.Compat.Prelude
import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Compat.Parsec (integral)
import qualified Text.Parsec as P
--import qualified Text.Parsec.Pos as P
import qualified Text.Parsec.Error as P
import Distribution.Parsec.Class (Parsec (..))
import Distribution.Parsec.Types.Common
import Distribution.Parsec.Types.Field (SectionArg (..))
......@@ -18,20 +13,24 @@ import Distribution.Simple.Utils (fromUTF8BS)
import Distribution.Types.GenericPackageDescription
(Condition (..), ConfVar (..))
import Distribution.Version
(mkVersion, anyVersion, earlierVersion,
intersectVersionRanges, laterVersion, noVersion, majorBoundVersion,
(anyVersion, earlierVersion, intersectVersionRanges,
laterVersion, majorBoundVersion, mkVersion, noVersion,
orEarlierVersion, orLaterVersion, thisVersion,
unionVersionRanges, withinVersion)
import qualified Text.Parsec as P
import qualified Text.Parsec.Error as P
-- | Parse @'Condition' 'ConfVar'@ from section arguments provided by parsec
-- based outline parser.
parseConditionConfVar :: [SectionArg Position] -> ParseResult (Condition ConfVar)
parseConditionConfVar args = do
-- Warnings!
-- preprocess glued operators
args' <- preprocess args
-- The name of the input file is irrelevant, as we reformat the error message.
case P.runParser (parser <* P.eof) () "<condition>" args' of
Right x -> pure x
Left err -> do
-- Mangle the position to the actual one
let ppos = P.errorPos err
let epos = Position (P.sourceLine ppos) (P.sourceColumn ppos)
let msg = P.showErrorMessages
......@@ -41,6 +40,9 @@ parseConditionConfVar args = do
pure $ Lit True
-- This is a hack, as we have "broken" .cabal files on Hackage
--
-- There are glued operators "&&!" (no whitespace) in some cabal files.
-- E.g. http://hackage.haskell.org/package/hblas-0.2.0.0/hblas.cabal
preprocess :: [SectionArg Position] -> ParseResult [SectionArg Position]
preprocess (SecArgOther pos "&&!" : rest) = do
parseWarning pos PWTGluedOperators "Glued operators: &&!"
......@@ -100,7 +102,7 @@ parser = condOr
("^>=", majorBoundVersion),
("==", thisVersion) ]
-- numbers are weird: SecArgNum (Position 65 15) "7.6.1"
-- Number token can have many dots in it: SecArgNum (Position 65 15) "7.6.1"
ident = tokenPrim $ \case
SecArgName _ s -> Just $ fromUTF8BS s
SecArgNum _ s -> Just $ fromUTF8BS s
......@@ -125,6 +127,7 @@ parser = condOr
parens = P.between (oper "(") (oper ")")
tokenPrim = P.tokenPrim prettySectionArg updatePosition
-- TODO: check where the errors are reported
updatePosition x _ _ = x
prettySectionArg = show
......
......@@ -31,19 +31,17 @@ module Distribution.Parsec.LexerMonad (
) where
import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Parsec.Types.Common (Position (..), PWarning (..), PWarnType (..))
import qualified Data.ByteString as B
import Prelude ()
import Distribution.Compat.Prelude
import qualified Data.ByteString as B
import Distribution.Parsec.Types.Common
(PWarnType (..), PWarning (..), Position (..))
#ifdef CABAL_PARSEC_DEBUG
-- testing only:
import qualified Data.Vector as V
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Vector as V
#endif
-- simple state monad
......@@ -80,12 +78,12 @@ toPWarning (LexWarning t p s) = PWarning t' p s
LexWarningBOM -> PWTLexBOM
data LexState = LexState {
curPos :: {-# UNPACK #-} !Position, -- position at current input location
curInput :: {-# UNPACK #-} !InputStream, -- the current input
curCode :: {-# UNPACK #-} !StartCode, -- lexer code
curPos :: {-# UNPACK #-} !Position, -- ^ position at current input location
curInput :: {-# UNPACK #-} !InputStream, -- ^ the current input
curCode :: {-# UNPACK #-} !StartCode, -- ^ lexer code
warnings :: [LexWarning]
#ifdef CABAL_PARSEC_DEBUG
, dbgText :: V.Vector T.Text
, dbgText :: V.Vector T.Text -- ^ input lines, to print pretty debug info
#endif
} --TODO: check if we should cache the first token
-- since it looks like parsec's uncons can be called many times on the same input
......
{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
#ifdef CABAL_PARSEC_DEBUG
{-# LANGUAGE PatternGuards #-}
#endif
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Parsec.Parser
......@@ -29,29 +27,23 @@ module Distribution.Parsec.Parser (
#endif
) where
import Prelude ()
import Distribution.Compat.Prelude
import Prelude
()
-- TODO: introduce Distribution.Compat.Parsec
import Control.Monad (guard)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import Data.Functor.Identity
import Distribution.Parsec.Lexer
import Distribution.Parsec.LexerMonad
(LexResult (..), LexState (..), LexWarning (..), LexWarningType (..), unLex)
(LexResult (..), LexState (..), LexWarning (..),
LexWarningType (..), unLex)
import Distribution.Parsec.Types.Common
import Distribution.Parsec.Types.Field
import Distribution.Utils.String
import Control.Monad
(guard)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import Data.Functor.Identity
import Text.Parsec.Combinator hiding
(eof, notFollowedBy)
import Text.Parsec.Combinator hiding (eof, notFollowedBy)
import Text.Parsec.Error
import Text.Parsec.Pos
import Text.Parsec.Prim hiding
(many, (<|>))
import Text.Parsec.Prim hiding (many, (<|>))
#ifdef CABAL_PARSEC_DEBUG
import qualified Data.Text as T
......@@ -59,6 +51,8 @@ import qualified Data.Text.Encoding as T
import qualified Data.Text.Encoding.Error as T
#endif
-- | The 'LexState'' (with a prime) is an instance of parsec's 'Stream'
-- wrapped around lexer's 'LexState' (without a prime)
data LexState' = LexState' !LexState (LToken, LexState')
mkLexState' :: LexState -> LexState'
......@@ -79,6 +73,7 @@ getLexerWarnings = do
LexState' (LexState { warnings = ws }) _ <- getInput
return ws
-- | Set Alex code i.e. the mode "state" lexer is in.
setLexerMode :: Int -> Parser ()
setLexerMode code = do
LexState' ls _ <- getInput
......@@ -170,15 +165,17 @@ inLexerMode (LexerMode mode) p =
-- $grammar
--
-- @
-- SecElems ::= SecElem* '\n'?
-- SecElem ::= '\n' SecElemLayout | SecElemBraces
-- SecElemLayout ::= FieldLayout | FieldBraces | SectionLayout | SectionBraces
-- SecElemBraces ::= FieldInline | FieldBraces | SectionBraces
-- FieldLayout ::= name ':' line? ('\n' line)*
-- FieldBraces ::= name ':' '\n'? '{' content '}'
-- FieldInline ::= name ':' content
-- SectionLayout ::= name arg* SecElems
-- SectionBraces ::= name arg* '\n'? '{' SecElems '}'
-- CabalStyleFile ::= SecElems
--
-- SecElems ::= SecElem* '\n'?
-- SecElem ::= '\n' SecElemLayout | SecElemBraces
-- SecElemLayout ::= FieldLayout | FieldBraces | SectionLayout | SectionBraces
-- SecElemBraces ::= FieldInline | FieldBraces | SectionBraces
-- FieldLayout ::= name ':' line? ('\n' line)*
-- FieldBraces ::= name ':' '\n'? '{' content '}'
-- FieldInline ::= name ':' content
-- SectionLayout ::= name arg* SecElems
-- SectionBraces ::= name arg* '\n'? '{' SecElems '}'
-- @
--
-- and the same thing but left factored...
......@@ -276,16 +273,19 @@ elementInNonLayoutContext name =
-- fieldLayoutOrBraces ::= '\n'? '{' content '}'
-- | line? ('\n' line)*
fieldLayoutOrBraces :: IndentLevel -> Name Position -> Parser (Field Position)
fieldLayoutOrBraces ilevel name =
(do openBrace
fieldLayoutOrBraces ilevel name = braces <|> fieldLayout
where
braces = do
openBrace
ls <- inLexerMode (LexerMode in_field_braces) (many fieldContent)
closeBrace
return (Field name ls))
<|> (inLexerMode (LexerMode in_field_layout)
(do l <- option (FieldLine (Position 0 0) B8.empty) fieldContent
--FIXME ^^ having to add an extra empty here is silly!
ls <- many (do _ <- indentOfAtLeast ilevel; fieldContent)
return (Field name (l:ls))))
return (Field name ls)
fieldLayout = inLexerMode (LexerMode in_field_layout) $ do
l <- optionMaybe fieldContent
ls <- many (do _ <- indentOfAtLeast ilevel; fieldContent)
return $ case l of
Nothing -> Field name ls
Just l' -> Field name (l' : ls)
-- The body of a section, using either layout style or braces style.
--
......@@ -314,9 +314,11 @@ fieldInlineOrBraces name =
return (Field name ls))
-- | Parse cabal style 'B8.ByteString' into list of 'Field's, i.e. the cabal AST.
readFields :: B8.ByteString -> Either ParseError [Field Position]
readFields s = fmap fst (readFields' s)
-- | Like 'readFields' but also return lexer warnings
readFields' :: B8.ByteString -> Either ParseError ([Field Position], [LexWarning])
readFields' s = do
parse parser "the input" lexSt
......@@ -329,7 +331,16 @@ readFields' s = do
(w, s') = fmap B.pack . recodeStringUtf8 . B.unpack $ s
lexSt = mkLexState' (mkLexState s')
-- TODO: For some reason alex parser cannot handle BOM, is it a bug?
-- TODO: For some reason alex parser cannot handle BOM.
--
-- There is $bom token in the lexer, but for some reason it's not matched,
-- and alex chockes.
--
-- It might be that I (phadej) don't have enough alex-fu
--
-- Anyway, we probably should operate alex in the byte mode, and do utf8 decoding
-- later in the fields where it's required (as we actually do atm). We'd need
-- alex-3.2 for that.
recodeStringUtf8 :: [Word8] -> (Maybe LexWarning, [Word8])
recodeStringUtf8 (0xef : 0xbb : 0xbf : bytes) =
( Just $ LexWarning LexWarningBOM (Position 1 1) "Byte-order mark found"
......@@ -372,6 +383,7 @@ formatError input perr =
"expecting" "unexpected" "end of file"
(errorMessages perr)
-- | Handles windows/osx/unix line breaks uniformly
lines' :: T.Text -> [T.Text]
lines' s1
| T.null s1 = []
......@@ -389,5 +401,3 @@ eof = notFollowedBy anyToken <?> "end of file"
notFollowedBy :: Parser LToken -> Parser ()
notFollowedBy p = try ( (do L _ t <- try p; unexpected (describeToken t))
<|> return ())
--showErrorMessages "or" "unknown parse error"
-- "expecting" "unexpected" "end of input"
......@@ -15,12 +15,10 @@ module Distribution.Parsec.Types.Common (
showPos,
) where
import Prelude ()
import Distribution.Compat.Prelude
import System.FilePath (normalise)
import qualified Text.Parsec as Parsec
import Prelude ()
import Distribution.Compat.Prelude
import System.FilePath (normalise)
import qualified Text.Parsec as Parsec
-- | Parser error.
data PError = PError Position String
......
......@@ -16,13 +16,11 @@ module Distribution.Parsec.Types.Field (
nameAnn,
) where
import Prelude ()
import Distribution.Compat.Prelude
import Data.ByteString (ByteString)
import qualified Data.Char as Char
import qualified Data.ByteString.Char8 as B
import Prelude ()
import Distribution.Compat.Prelude
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as B
import qualified Data.Char as Char
-------------------------------------------------------------------------------
-- Cabal file
......@@ -51,7 +49,7 @@ data SectionArg ann
| SecArgStr !ann !String
-- ^ quoted string
| SecArgNum !ann !ByteString
-- ^ integral number
-- ^ Something which loos like number. Also many dot numbers, i.e. "7.6.3"
| SecArgOther !ann !ByteString
-- ^ everything else, mm. operators (e.g. in if-section conditionals)
deriving (Eq, Show, Functor)
......
......@@ -32,20 +32,18 @@ module Distribution.Parsec.Types.FieldDescr (
ignoreUnrec,
) where
import Distribution.Compat.Prelude hiding (get)
import Prelude ()
import Distribution.Compat.Prelude hiding (get)
import qualified Data.ByteString as BS
import Data.Ord (comparing)
import Text.PrettyPrint
(Doc, colon, comma, fsep, hsep, isEmpty, nest, punctuate,
text, vcat, ($+$), (<+>))
import qualified Distribution.Compat.Parsec as P
import Distribution.Compiler (CompilerFlavor)
import Distribution.Parsec.Class
import Distribution.Parsec.Types.Common
import Distribution.PrettyUtils
import Text.PrettyPrint
(Doc, colon, comma, fsep, hsep, isEmpty, nest, punctuate,
text, vcat, ($+$), (<+>))
type FieldName = BS.ByteString
......
......@@ -11,9 +11,8 @@ module Distribution.Parsec.Types.ParseResult (
parseWarnings',
) where
import Distribution.Compat.Prelude
import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Parsec.Types.Common
(PError (..), PWarnType (..), PWarning (..), Position (..))
......@@ -66,7 +65,7 @@ parseWarning pos t msg = PR $ \(PRState warns errs) ->
parseWarnings' :: [PWarning] -> ParseResult ()
parseWarnings' newWarns = PR $ \(PRState warns errs) ->
(Just (), PRState (warns ++ newWarns) errs)
(Just (), PRState (warns ++ newWarns) errs)
-- | Add an error, but not fail the parser yet.
--
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment