diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,8 +1,20 @@ +### 0.1.1.1 + +* Reject (illegal) non-scalar code-points in UTF-32 streams +* Tolerate BOM at start of stream +* Disambiguate choice in `l-any-document` production regarding token separation of `c-directives-end` +* Fix `c-indentation-indicator(n)` grammar production when + auto-detecting indentation in the presence of empty leading lines; + also reject (illegal) auto-indent-level scalars with leading + more-indented all-space lines +* Complete character escape rules for double-quoted scalars +* Minor optimizations + ### 0.1.1.0 * `Data.YAML` module promoted from `TrustWorthy` to `Safe` * Add `FromYAML Natural` instance -* Add `Alternative` and `MonadPlus` instances for `Data.YAML.Parser` +* Add `MonadFail`, `Alternative`, and `MonadPlus` instances for `Data.YAML.Parser` * Add `Data.YAML.decodeStrict` function * Export `Data.YAML.typeMismatch` helper function diff --git a/HsYAML.cabal b/HsYAML.cabal --- a/HsYAML.cabal +++ b/HsYAML.cabal @@ -1,6 +1,6 @@ cabal-version: 1.14 name: HsYAML -version: 0.1.1.0 +version: 0.1.1.1 synopsis: Pure Haskell YAML 1.2 parser homepage: https://github.com/hvr/HsYAML @@ -47,6 +47,7 @@ , Data.YAML.Token other-modules: Data.YAML.Loader , Data.YAML.Schema + , Data.YAML.Token.Encoding , Util default-language: Haskell2010 diff --git a/src-test/Main.hs b/src-test/Main.hs --- a/src-test/Main.hs +++ b/src-test/Main.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} -- | -- Copyright: © Herbert Valerio Riedel 2018 @@ -11,12 +12,14 @@ import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BS.L import Data.Int (Int64) +import Data.List (groupBy) import Data.Maybe import System.Directory import System.Environment import System.Exit import System.FilePath import System.IO +import Text.Printf (printf) import Text.Read import qualified Data.Aeson.Micro as J @@ -44,6 +47,12 @@ hPutStrLn stderr "unexpected arguments passed to yaml2event sub-command" exitFailure + ("yaml2token":args') + | null args' -> cmdYaml2Token + | otherwise -> do + hPutStrLn stderr "unexpected arguments passed to yaml2token sub-command" + exitFailure + ("yaml2json":args') | null args' -> cmdYaml2Json | otherwise -> do @@ -67,6 +76,19 @@ exitFailure + +cmdYaml2Token :: IO () +cmdYaml2Token = do + inYamlDat <- BS.L.getContents + forM_ (groupBy (\x y -> YT.tLine x == YT.tLine y) $ YT.tokenize inYamlDat False) $ \lgrp -> do + forM_ lgrp $ \YT.Token{..} -> do + let tText' | null tText = "" + | any (== ' ') tText = replicate tLineChar ' ' ++ show tText + | otherwise = replicate (tLineChar+1) ' ' ++ tail (init (show tText)) + hPutStrLn stdout $ printf ":%d:%d: %-15s| %s" tLine tLineChar (show tCode) tText' + hPutStrLn stdout "" + hFlush stdout + cmdYaml2Event :: IO () cmdYaml2Event = do inYamlDat <- BS.L.getContents @@ -124,7 +146,9 @@ NumberD' t -> pure (T.pack (show t)) String' t -> pure t Null' -> pure "" - _ -> fail ("dictionary entry had non-string key " ++ show k) + -- we stringify the key with an added risk of nameclashing + _ -> pure $ T.decodeUtf8 $ J.encodeStrict $ toProperValue k +-- _ -> fail ("dictionary entry had non-string key " ++ show k) decodeAeson :: BS.L.ByteString -> Either String [J.Value] decodeAeson = fmap (map toProperValue) . decode diff --git a/src/Data/YAML.hs b/src/Data/YAML.hs --- a/src/Data/YAML.hs +++ b/src/Data/YAML.hs @@ -440,6 +440,11 @@ -- 'decode' uses the same settings as 'decodeNode' for tag-resolving. If -- you need a different custom parsing configuration, you need to -- combine 'parseEither' and `decodeNode'` yourself. +-- +-- The 'decode' as well as the 'decodeNode' functions supports +-- decoding from YAML streams using the UTF-8, UTF-16 (LE or BE), or +-- UTF-32 (LE or BE) encoding (which is auto-detected). +-- decode :: FromYAML v => BS.L.ByteString -> Either String [v] decode bs0 = decodeNode bs0 >>= mapM (parseEither . parseYAML . (\(Doc x) -> x)) diff --git a/src/Data/YAML/Event.hs b/src/Data/YAML/Event.hs --- a/src/Data/YAML/Event.hs +++ b/src/Data/YAML/Event.hs @@ -166,8 +166,12 @@ -} -- | Parse YAML 'Event's from a lazy 'BS.L.ByteString'. +-- +-- The input 'BS.L.ByteString' is expected to have a YAML 1.2 stream +-- using the UTF-8, UTF-16 (LE or BE), or UTF-32 (LE or BE) encodings +-- (which will be auto-detected). parseEvents :: BS.L.ByteString -> EvStream -parseEvents = \bs0 -> Right StreamStart : (go0 mempty $ stripComments $ filter (not . isWhite) (Y.tokenize bs0 False)) +parseEvents = \bs0 -> Right StreamStart : (go0 mempty $ stripComments $ filter (not . isWhite) $ eatBom $ Y.tokenize bs0 False) where isTCode tc = (== tc) . Y.tCode skipPast tc (t : ts) @@ -175,6 +179,9 @@ | otherwise = skipPast tc ts skipPast _ [] = error "the impossible happened" + eatBom :: [Y.Token] -> [Y.Token] + eatBom (Y.Token { Y.tCode = Y.Bom } : ts) = ts + eatBom ts = ts isWhite :: Y.Token -> Bool isWhite (Y.Token { Y.tCode = Y.White }) = True @@ -307,57 +314,84 @@ goTag _ xs _ = err xs goScalar :: Props -> Tok2EvStreamCont - goScalar (manchor,tag) toks0 cont = go' "" Plain toks0 + goScalar (manchor,tag) toks0 cont = go0 False Plain toks0 where - go' acc sty (Y.Token { Y.tCode = Y.Text, Y.tText = t } : rest) = go' (acc ++ t) sty rest - go' acc sty (Y.Token { Y.tCode = Y.LineFold } : rest) = go' (acc ++ " ") sty rest - go' acc sty (Y.Token { Y.tCode = Y.LineFeed } : rest) = go' (acc ++ "\n") sty rest + go0 ii sty (Y.Token { Y.tCode = Y.Indicator, Y.tText = ind } : rest) + | "'" <- ind = go' ii "" SingleQuoted rest + | "\"" <- ind = go' ii "" DoubleQuoted rest + | "|" <- ind = go0 True Literal rest + | ">" <- ind = go0 True Folded rest - go' acc sty (Y.Token { Y.tCode = Y.BeginEscape } : + | "+" <- ind = go0 ii sty rest + | "-" <- ind = go0 ii sty rest + | [c] <- ind, '1' <= c, c <= '9' = go0 False sty rest + + go0 ii sty (Y.Token { Y.tCode = Y.Text, Y.tText = t } : rest) = go' ii t sty rest + go0 ii sty (Y.Token { Y.tCode = Y.LineFold } : rest) = go' ii " " sty rest + go0 ii sty (Y.Token { Y.tCode = Y.LineFeed } : rest) = go' ii "\n" sty rest + go0 _ sty (Y.Token { Y.tCode = Y.EndScalar } : rest) = Right (Scalar manchor tag sty mempty) : cont rest + + go0 _ _ xs = err xs + + ---------------------------------------------------------------------------- + + go' ii acc sty (Y.Token { Y.tCode = Y.Text, Y.tText = t } : rest) = go' ii (acc ++ t) sty rest + go' ii acc sty (Y.Token { Y.tCode = Y.LineFold } : rest) = go' ii (acc ++ " ") sty rest + go' ii acc sty (Y.Token { Y.tCode = Y.LineFeed } : rest) = go' ii (acc ++ "\n") sty rest + + go' ii acc sty@SingleQuoted + (Y.Token { Y.tCode = Y.BeginEscape } : Y.Token { Y.tCode = Y.Indicator, Y.tText = "'" } : Y.Token { Y.tCode = Y.Meta, Y.tText = "'" } : Y.Token { Y.tCode = Y.EndEscape } : - rest) = go' (acc ++ "'") sty rest + rest) = go' ii (acc ++ "'") sty rest - go' acc sty (Y.Token { Y.tCode = Y.BeginEscape } : + go' ii acc sty@SingleQuoted + (Y.Token { Y.tCode = Y.Indicator, Y.tText = "'" } : + rest) = go' ii acc sty rest + + go' ii acc sty@DoubleQuoted + (Y.Token { Y.tCode = Y.BeginEscape } : Y.Token { Y.tCode = Y.Indicator, Y.tText = "\\" } : -- Y.Token { Y.tCode = Y.Break } : Y.Token { Y.tCode = Y.EndEscape } : - rest) = go' acc sty rest -- end-line + rest) = go' ii acc sty rest -- line continuation escape - go' acc sty (Y.Token { Y.tCode = Y.BeginEscape } : + go' ii acc sty@DoubleQuoted + (Y.Token { Y.tCode = Y.BeginEscape } : Y.Token { Y.tCode = Y.Indicator, Y.tText = "\\" } : Y.Token { Y.tCode = Y.Meta, Y.tText = t } : Y.Token { Y.tCode = Y.EndEscape } : rest) - | t == "n" = go' (acc ++ "\n") sty rest - | t == "r" = go' (acc ++ "\r") sty rest - | t == "t" = go' (acc ++ "\t") sty rest - | t == "b" = go' (acc ++ "\b") sty rest - | t == "/" = go' (acc ++ t) sty rest - | t == " " = go' (acc ++ t) sty rest - | t == "\\" = go' (acc ++ t) sty rest - | t == "\"" = go' (acc ++ t) sty rest + | Just t' <- unescape t = go' ii (acc ++ t') sty rest - go' acc sty (Y.Token { Y.tCode = Y.BeginEscape } : + go' ii acc sty@DoubleQuoted + (Y.Token { Y.tCode = Y.BeginEscape } : Y.Token { Y.tCode = Y.Indicator, Y.tText = "\\" } : Y.Token { Y.tCode = Y.Indicator, Y.tText = pfx } : Y.Token { Y.tCode = Y.Meta, Y.tText = ucode } : Y.Token { Y.tCode = Y.EndEscape } : rest) - | pfx == "u", Just c <- decodeCP ucode = go' (acc ++ [c]) sty rest - | pfx == "x", Just c <- decodeL1 ucode = go' (acc ++ [c]) sty rest + | pfx == "U", Just c <- decodeCP2 ucode = go' ii (acc ++ [c]) sty rest + | pfx == "u", Just c <- decodeCP ucode = go' ii (acc ++ [c]) sty rest + | pfx == "x", Just c <- decodeL1 ucode = go' ii (acc ++ [c]) sty rest - go' acc sty (Y.Token { Y.tCode = Y.Indicator, Y.tText = ind } : rest) - | "'" <- ind = go' acc SingleQuoted rest - | "\"" <- ind = go' acc DoubleQuoted rest - | "|" <- ind = go' acc Literal rest - | ">" <- ind = go' acc Folded rest - | otherwise = go' acc sty rest - go' acc sty (Y.Token { Y.tCode = Y.EndScalar } : rest) = Right (Scalar manchor tag sty (T.pack acc)) : cont rest - go' _ _ xs | False = error (show xs) - go' _ _ xs = err xs + go' ii acc sty@DoubleQuoted + (Y.Token { Y.tCode = Y.Indicator, Y.tText = "\"" } : + rest) = go' ii acc sty rest + go' ii acc sty (t@Y.Token { Y.tCode = Y.EndScalar } : + rest) + | ii, hasLeadingSpace acc = [Left (tok2pos t, "leading empty lines contain more spaces than the first non-empty line in scalar")] + | otherwise = Right (Scalar manchor tag sty (T.pack acc)) : cont rest + + go' _ _ _ xs | False = error (show xs) + go' _ _ _ xs = err xs + + hasLeadingSpace (' ':_) = True + hasLeadingSpace ('\n':cs) = hasLeadingSpace cs + hasLeadingSpace _ = False + goSeq :: Tok2EvStreamCont goSeq (Y.Token { Y.tCode = Y.EndSequence } : rest) cont = Right SequenceEnd : cont rest goSeq (Y.Token { Y.tCode = Y.BeginNode } : rest) cont = goNode rest (flip goSeq cont) @@ -400,6 +434,13 @@ type Cont r a = (a -> r) -> r +-- decode 8-hex-digit unicode code-point +decodeCP2 :: String -> Maybe Char +decodeCP2 s = case s of + [_,_,_,_,_,_,_,_] | all isHexDigit s + , [(j, "")] <- readHex s -> Just (chr (fromInteger j)) + _ -> Nothing + -- decode 4-hex-digit unicode code-point decodeCP :: String -> Maybe Char decodeCP s = case s of @@ -413,3 +454,33 @@ [_,_] | all isHexDigit s , [(j, "")] <- readHex s -> Just (chr (fromInteger j)) _ -> Nothing + +-- decode C-style escapes +unescape :: String -> Maybe String +unescape [c] = Map.lookup c m + where + m = Map.fromList [ (k,[v]) | (k,v) <- escapes ] + + escapes :: [(Char,Char)] + escapes = + [ ('0', '\0') + , ('a', '\x7') + , ('b', '\x8') + , ('\x9', '\x9') + , ('t', '\x9') + , ('n', '\xa') + , ('v', '\xb') + , ('f', '\xc') + , ('r', '\xd') + , ('e', '\x1b') + , (' ', ' ') + , ('"', '"') + , ('/', '/') + , ('\\', '\\') + , ('N', '\x85') + , ('_', '\xa0') + , ('L', '\x2028') + , ('P', '\x2029') + ] +unescape _ = Nothing + diff --git a/src/Data/YAML/Token.hs b/src/Data/YAML/Token.hs --- a/src/Data/YAML/Token.hs +++ b/src/Data/YAML/Token.hs @@ -25,12 +25,14 @@ ) where import qualified Data.ByteString.Lazy.Char8 as BLC -import Data.Char (chr, ord) import qualified Data.DList as D import Prelude hiding ((*), (+), (-), (/), (^)) import qualified Prelude +import Data.YAML.Token.Encoding (Encoding (..), decode) + import Util hiding (empty) +import qualified Util -- * Generic operators -- @@ -53,263 +55,24 @@ (.-) :: Int -> Int -> Int (.-) = (Prelude.-) +{- infixl 7 .* -- | \".*\" is the numeric multiplication (we use \"*\" for postfix \"zero or -- more\"). (.*) :: Int -> Int -> Int (.*) = (Prelude.*) +-} -- ** Record field access -- --- We also define @|>@ for record access for increased readability. - -infixl 9 |> --- | @record |> field@ is the same as @field record@, but is more readable. -(|>) :: record -> (record -> value) -> value -record |> field = field record +-- We also define @^.@ for record access for increased readability. --- * UTF decoding +infixl 8 ^. +-- | @record ^. field@ is the same as @field record@, but is more readable. -- --- This really should be factored out to the standard libraries. Since it isn't --- there, we get to tailor it exactly to our needs. We use lazy byte strings as --- input, which should give reasonable I\/O performance when reading large --- files. The output is a normal 'Char' list which is easy to work with and --- should be efficient enough as long as the 'Parser' does its job right. - --- | Recognized Unicode encodings. As of YAML 1.2 UTF-32 is also required. -data Encoding = UTF8 -- ^ UTF-8 encoding (or ASCII) - | UTF16LE -- ^ UTF-16 little endian - | UTF16BE -- ^ UTF-16 big endian - | UTF32LE -- ^ UTF-32 little endian - | UTF32BE -- ^ UTF-32 big endian - --- | @show encoding@ converts an 'Encoding' to the encoding name (with a "-") --- as used by most programs. -instance Show Encoding where - show UTF8 = "UTF-8" - show UTF16LE = "UTF-16LE" - show UTF16BE = "UTF-16BE" - show UTF32LE = "UTF-32LE" - show UTF32BE = "UTF-32BE" - --- | @decode bytes@ automatically detects the 'Encoding' used and converts the --- /bytes/ to Unicode characters, with byte offsets. Note the offset is for --- past end of the character, not its beginning. -decode :: BLC.ByteString -> (Encoding, [(Int, Char)]) -decode text = (encoding, undoEncoding encoding text) - where encoding = detectEncoding $ BLC.unpack $ BLC.take 4 text - --- | @detectEncoding text@ examines the first few chars (bytes) of the /text/ --- to deduce the Unicode encoding used according to the YAML spec. -detectEncoding :: [Char] -> Encoding -detectEncoding text = - case text of - '\x00' : '\x00' : '\xFE' : '\xFF' : _ -> UTF32BE - '\x00' : '\x00' : '\x00' : _ : _ -> UTF32BE - '\xFF' : '\xFE' : '\x00' : '\x00' : _ -> UTF32LE - _ : '\x00' : '\x00' : '\x00' : _ -> UTF32LE - '\xFE' : '\xFF' : _ -> UTF16BE - '\x00' : _ : _ -> UTF16BE - '\xFF' : '\xFE' : _ -> UTF16LE - _ : '\x00' : _ -> UTF16LE - '\xEF' : '\xBB' : '\xBF' : _ -> UTF8 - _ -> UTF8 - --- | @undoEncoding encoding bytes@ converts a /bytes/ stream to Unicode --- characters according to the /encoding/. -undoEncoding :: Encoding -> BLC.ByteString -> [(Int, Char)] -undoEncoding encoding bytes = - case encoding of - UTF8 -> undoUTF8 bytes 0 - UTF16LE -> combinePairs $ undoUTF16LE bytes 0 - UTF16BE -> combinePairs $ undoUTF16BE bytes 0 - UTF32LE -> combinePairs $ undoUTF32LE bytes 0 - UTF32BE -> combinePairs $ undoUTF32BE bytes 0 - --- ** UTF-32 decoding - --- | @hasFewerThan bytes n@ checks whether there are fewer than /n/ /bytes/ --- left to read. -hasFewerThan :: Int -> BLC.ByteString -> Bool -hasFewerThan n bytes - | n == 1 = BLC.null bytes - | n > 1 = BLC.null bytes || hasFewerThan (n .- 1) (BLC.tail bytes) - | otherwise = False - --- | @undoUTF32LE bytes offset@ decoded a UTF-32LE /bytes/ stream to Unicode --- chars. -undoUTF32LE :: BLC.ByteString -> Int -> [(Int, Char)] -undoUTF32LE bytes offset - | BLC.null bytes = [] - | hasFewerThan 4 bytes = error "UTF-32LE input contains invalid number of bytes" - | otherwise = let first = BLC.head bytes - bytes' = BLC.tail bytes - second = BLC.head bytes' - bytes'' = BLC.tail bytes' - third = BLC.head bytes'' - bytes''' = BLC.tail bytes'' - fourth = BLC.head bytes''' - rest = BLC.tail bytes''' - in (offset .+ 4, - chr $ (ord first) - .+ 256 .* ((ord second) - .+ 256 .* ((ord third) - .+ 256 .* ((ord fourth))))):(undoUTF32LE rest $ offset .+ 4) - --- | @undoUTF32BE bytes offset@ decoded a UTF-32BE /bytes/ stream to Unicode --- chars. -undoUTF32BE :: BLC.ByteString -> Int -> [(Int, Char)] -undoUTF32BE bytes offset - | BLC.null bytes = [] - | hasFewerThan 4 bytes = error "UTF-32BE input contains invalid number of bytes" - | otherwise = let first = BLC.head bytes - bytes' = BLC.tail bytes - second = BLC.head bytes' - bytes'' = BLC.tail bytes' - third = BLC.head bytes'' - bytes''' = BLC.tail bytes'' - fourth = BLC.head bytes''' - rest = BLC.tail bytes''' - in (offset .+ 4, - chr $ (ord fourth) - .+ 256 .* ((ord third) - .+ 256 .* ((ord second) - .+ 256 .* ((ord first))))):(undoUTF32BE rest $ offset .+ 4) - --- ** UTF-16 decoding - --- | @combinePairs chars@ converts each pair of UTF-16 surrogate characters to a --- single Unicode character. -combinePairs :: [(Int, Char)] -> [(Int, Char)] -combinePairs [] = [] -combinePairs (head@(_, head_char):tail) - | '\xD800' <= head_char && head_char <= '\xDBFF' = combineLead head tail - | '\xDC00' <= head_char && head_char <= '\xDFFF' = error "UTF-16 contains trail surrogate without lead surrogate" - | otherwise = head:(combinePairs tail) - --- | @combineLead lead rest@ combines the /lead/ surrogate with the head of the --- /rest/ of the input chars, assumed to be a /trail/ surrogate, and continues --- combining surrogate pairs. -combineLead :: (Int, Char) -> [(Int, Char)] -> [(Int, Char)] -combineLead _lead [] = error "UTF-16 contains lead surrogate as final character" -combineLead (_, lead_char) ((trail_offset, trail_char):rest) - | '\xDC00' <= trail_char && trail_char <= '\xDFFF' = (trail_offset, combineSurrogates lead_char trail_char):combinePairs rest - | otherwise = error "UTF-16 contains lead surrogate without trail surrogate" - --- | @surrogateOffset@ is copied from the Unicode FAQs. -surrogateOffset :: Int -surrogateOffset = 0x10000 .- (0xD800 .* 1024) .- 0xDC00 - --- | @combineSurrogates lead trail@ combines two UTF-16 surrogates into a single --- Unicode character. -combineSurrogates :: Char -> Char -> Char -combineSurrogates lead trail = chr $ (ord lead) .* 1024 .+ (ord trail) .+ surrogateOffset - --- | @undoUTF18LE bytes offset@ decoded a UTF-16LE /bytes/ stream to Unicode --- chars. -undoUTF16LE :: BLC.ByteString -> Int -> [(Int, Char)] -undoUTF16LE bytes offset - | BLC.null bytes = [] - | hasFewerThan 2 bytes = error "UTF-16LE input contains odd number of bytes" - | otherwise = let low = BLC.head bytes - bytes' = BLC.tail bytes - high = BLC.head bytes' - rest = BLC.tail bytes' - in (offset .+ 2, chr $ (ord low) .+ (ord high) .* 256):(undoUTF16LE rest $ offset .+ 2) - --- | @undoUTF18BE bytes offset@ decoded a UTF-16BE /bytes/ stream to Unicode --- chars. -undoUTF16BE :: BLC.ByteString -> Int -> [(Int, Char)] -undoUTF16BE bytes offset - | BLC.null bytes = [] - | hasFewerThan 2 bytes = error "UTF-16BE input contains odd number of bytes" - | otherwise = let high = BLC.head bytes - bytes' = BLC.tail bytes - low = BLC.head bytes' - rest = BLC.tail bytes' - in (offset .+ 2, chr $ (ord low) .+ (ord high) .* 256):(undoUTF16BE rest $ offset .+ 2) - --- ** UTF-8 decoding - --- | @undoUTF8 bytes offset@ decoded a UTF-8 /bytes/ stream to Unicode chars. -undoUTF8 :: BLC.ByteString -> Int -> [(Int, Char)] -undoUTF8 bytes offset - | BLC.null bytes = [] - | otherwise = let first = BLC.head bytes - rest = BLC.tail bytes - in case () of - _ | first < '\x80' -> (offset .+ 1, first):(undoUTF8 rest $ offset .+ 1) - | first < '\xC0' -> error $ "UTF-8 input contains invalid first byte" - | first < '\xE0' -> decodeTwoUTF8 first offset rest - | first < '\xF0' -> decodeThreeUTF8 first offset rest - | first < '\xF8' -> decodeFourUTF8 first offset rest - | otherwise -> error $ "UTF-8 input contains invalid first byte" - --- | @decodeTwoUTF8 first offset bytes@ decodes a two-byte UTF-8 character, --- where the /first/ byte is already available and the second is the head of --- the /bytes/, and then continues to undo the UTF-8 encoding. -decodeTwoUTF8 :: Char -> Int -> BLC.ByteString -> [(Int, Char)] -decodeTwoUTF8 first offset bytes - | BLC.null bytes = error "UTF-8 double byte char is missing second byte at eof" - | otherwise = let second = BLC.head bytes - rest = BLC.tail bytes - in case () of - _ | second < '\x80' || '\xBF' < second -> error $ "UTF-8 double byte char has invalid second byte" - | otherwise -> (offset .+ 2, combineTwoUTF8 first second):(undoUTF8 rest $ offset .+ 2) - --- | @combineTwoUTF8 first second@ combines the /first/ and /second/ bytes of a --- two-byte UTF-8 char into a single Unicode char. -combineTwoUTF8 :: Char -> Char -> Char -combineTwoUTF8 first second = chr(((ord first) .- 0xC0) .* 64 - .+ ((ord second) .- 0x80)) - --- | @decodeThreeUTF8 first offset bytes@ decodes a three-byte UTF-8 character, --- where the /first/ byte is already available and the second and third are the --- head of the /bytes/, and then continues to undo the UTF-8 encoding. -decodeThreeUTF8 :: Char -> Int -> BLC.ByteString -> [(Int, Char)] -decodeThreeUTF8 first offset bytes - | hasFewerThan 2 bytes = error "UTF-8 triple byte char is missing bytes at eof" - | otherwise = let second = BLC.head bytes - bytes' = BLC.tail bytes - third = BLC.head bytes' - rest = BLC.tail bytes' - in case () of - _ | second < '\x80' || '\xBF' < second -> error "UTF-8 triple byte char has invalid second byte" - | third < '\x80' || '\xBF' < third -> error "UTF-8 triple byte char has invalid third byte" - | otherwise -> (offset .+ 3, combineThreeUTF8 first second third):(undoUTF8 rest $ offset .+ 3) - --- | @combineThreeUTF8 first second@ combines the /first/, /second/ and /third/ --- bytes of a three-byte UTF-8 char into a single Unicode char. -combineThreeUTF8 :: Char -> Char -> Char -> Char -combineThreeUTF8 first second third = chr(((ord first) .- 0xE0) .* 4096 - .+ ((ord second) .- 0x80) .* 64 - .+ ((ord third) .- 0x80)) - --- | @decodeFourUTF8 first offset bytes@ decodes a four-byte UTF-8 character, --- where the /first/ byte is already available and the second, third and fourth --- are the head of the /bytes/, and then continues to undo the UTF-8 encoding. -decodeFourUTF8 :: Char -> Int -> BLC.ByteString -> [(Int, Char)] -decodeFourUTF8 first offset bytes - | hasFewerThan 3 bytes = error "UTF-8 quad byte char is missing bytes at eof" - | otherwise = let second = BLC.head bytes - bytes' = BLC.tail bytes - third = BLC.head bytes' - bytes'' = BLC.tail bytes' - fourth = BLC.head bytes'' - rest = BLC.tail bytes'' - in case () of - _ | second < '\x80' || '\xBF' < second -> error "UTF-8 quad byte char has invalid second byte" - | third < '\x80' || '\xBF' < third -> error "UTF-8 quad byte char has invalid third byte" - | third < '\x80' || '\xBF' < third -> error "UTF-8 quad byte char has invalid fourth byte" - | otherwise -> (offset .+ 4, combineFourUTF8 first second third fourth):(undoUTF8 rest $ offset .+ 4) - --- | @combineFourUTF8 first second@ combines the /first/, /second/ and /third/ --- bytes of a three-byte UTF-8 char into a single Unicode char. -combineFourUTF8 :: Char -> Char -> Char -> Char -> Char -combineFourUTF8 first second third fourth = chr(((ord first) .- 0xF0) .* 262144 - .+ ((ord second) .- 0x80) .* 4096 - .+ ((ord third) .- 0x80) .* 64 - .+ ((ord fourth) .- 0x80)) +-- NB: This trivially emulates the @lens@ operator +(^.) :: record -> (record -> value) -> value +record ^. field = field record -- * Result tokens -- @@ -416,12 +179,12 @@ -- | Parsed token. data Token = Token { - tByteOffset :: Int, -- ^ 0-base byte offset in stream. - tCharOffset :: Int, -- ^ 0-base character offset in stream. - tLine :: Int, -- ^ 1-based line number. - tLineChar :: Int, -- ^ 0-based character in line. - tCode :: Code, -- ^ Specific token 'Code'. - tText :: String -- ^ Contained input chars, if any. + tByteOffset :: !Int, -- ^ 0-base byte offset in stream. + tCharOffset :: !Int, -- ^ 0-base character offset in stream. + tLine :: !Int, -- ^ 1-based line number. + tLineChar :: !Int, -- ^ 0-based character in line. + tCode :: !Code, -- ^ Specific token 'Code'. + tText :: !String -- ^ Contained input chars, if any. } deriving Show @@ -446,8 +209,11 @@ -- contains a polymorphic \"UserState\" field etc. -- | A 'Parser' is basically a function computing a 'Reply'. -data Parser result = Parser (State -> Reply result) +newtype Parser result = Parser (State -> Reply result) +applyParser :: Parser result -> State -> Reply result +applyParser (Parser p) s = p s + -- | The 'Result' of each invocation is either an error, the actual result, or -- a continuation for computing the actual result. data Result result = Failed String -- ^ Parsing aborted with a failure. @@ -466,16 +232,16 @@ data Reply result = Reply { rResult :: !(Result result), -- ^ Parsing result. rTokens :: !(D.DList Token), -- ^ Tokens generated by the parser. - rCommit :: !(Maybe String), -- ^ Commitment to a decision point. + rCommit :: !(Maybe Decision), -- ^ Commitment to a decision point. rState :: !State -- ^ The updated parser state. } -- Showing a 'State' is only used in debugging. instance (Show result) => Show (Reply result) where - show reply = "Result: " ++ (show $ reply|>rResult) - ++ ", Tokens: " ++ (show $ D.toList $ reply|>rTokens) - ++ ", Commit: " ++ (show $ reply|>rCommit) - ++ ", State: { " ++ (show $ reply|>rState) ++ "}" + show reply = "Result: " ++ (show $ reply^.rResult) + ++ ", Tokens: " ++ (show $ D.toList $ reply^.rTokens) + ++ ", Commit: " ++ (show $ reply^.rCommit) + ++ ", State: { " ++ (show $ reply^.rState) ++ "}" -- A 'Pattern' is a parser that doesn't have an (interesting) result. type Pattern = Parser () @@ -487,7 +253,7 @@ -- that it is that easy to draw the line - is @sLine@ generic or specific?). data State = State { sEncoding :: !Encoding, -- ^ The input UTF encoding. - sDecision :: !String, -- ^ Current decision name. + sDecision :: !Decision, -- ^ Current decision name. sLimit :: !Int, -- ^ Lookahead characters limit. sForbidden :: !(Maybe Pattern), -- ^ Pattern we must not enter into. sIsPeek :: !Bool, -- ^ Disables token generation. @@ -509,30 +275,30 @@ -- Showing a 'State' is only used in debugging. Note that forcing dump of -- @sInput@ will disable streaming it. instance Show State where - show state = "Encoding: " ++ (show $ state|>sEncoding) - ++ ", Decision: " ++ (show $ state|>sDecision) - ++ ", Limit: " ++ (show $ state|>sLimit) - ++ ", IsPeek: " ++ (show $ state|>sIsPeek) - ++ ", IsSol: " ++ (show $ state|>sIsSol) - ++ ", Chars: >>>" ++ (reverse $ state|>sChars) ++ "<<<" - ++ ", CharsByteOffset: " ++ (show $ state|>sCharsByteOffset) - ++ ", CharsCharOffset: " ++ (show $ state|>sCharsCharOffset) - ++ ", CharsLine: " ++ (show $ state|>sCharsLine) - ++ ", CharsLineChar: " ++ (show $ state|>sCharsLineChar) - ++ ", ByteOffset: " ++ (show $ state|>sByteOffset) - ++ ", CharOffset: " ++ (show $ state|>sCharOffset) - ++ ", Line: " ++ (show $ state|>sLine) - ++ ", LineChar: " ++ (show $ state|>sLineChar) - ++ ", Code: " ++ (show $ state|>sCode) - ++ ", Last: " ++ (show $ state|>sLast) --- ++ ", Input: >>>" ++ (show $ state|>sInput) ++ "<<<" + show state = "Encoding: " ++ (show $ state^.sEncoding) + ++ ", Decision: " ++ (show $ state^.sDecision) + ++ ", Limit: " ++ (show $ state^.sLimit) + ++ ", IsPeek: " ++ (show $ state^.sIsPeek) + ++ ", IsSol: " ++ (show $ state^.sIsSol) + ++ ", Chars: >>>" ++ (reverse $ state^.sChars) ++ "<<<" + ++ ", CharsByteOffset: " ++ (show $ state^.sCharsByteOffset) + ++ ", CharsCharOffset: " ++ (show $ state^.sCharsCharOffset) + ++ ", CharsLine: " ++ (show $ state^.sCharsLine) + ++ ", CharsLineChar: " ++ (show $ state^.sCharsLineChar) + ++ ", ByteOffset: " ++ (show $ state^.sByteOffset) + ++ ", CharOffset: " ++ (show $ state^.sCharOffset) + ++ ", Line: " ++ (show $ state^.sLine) + ++ ", LineChar: " ++ (show $ state^.sLineChar) + ++ ", Code: " ++ (show $ state^.sCode) + ++ ", Last: " ++ (show $ state^.sLast) +-- ++ ", Input: >>>" ++ (show $ state^.sInput) ++ "<<<" -- | @initialState name input@ returns an initial 'State' for parsing the -- /input/ (with /name/ for error messages). initialState :: BLC.ByteString -> State initialState input = State { sEncoding = encoding - , sDecision = "" + , sDecision = DeNone , sLimit = -1 , sForbidden = Nothing , sIsPeek = False @@ -632,37 +398,52 @@ -- | @unexpectedReply state@ returns a @failReply@ for an unexpected character. unexpectedReply :: State -> Reply result -unexpectedReply state = case state|>sInput of +unexpectedReply state = case state^.sInput of ((_, char):_) -> failReply state $ "Unexpected '" ++ [char] ++ "'" [] -> failReply state "Unexpected end of input" instance Functor Parser where - fmap = liftM + fmap g f = Parser $ \state -> + let reply = applyParser f state + in case reply^.rResult of + Failed message -> reply { rResult = Failed message } + Result x -> reply { rResult = Result (g x) } + More parser -> reply { rResult = More $ fmap g parser } + instance Applicative Parser where - pure = return + pure result = Parser $ \state -> returnReply state result + (<*>) = ap + left *> right = Parser $ \state -> + let reply = applyParser left state + in case reply^.rResult of + Failed message -> reply { rResult = Failed message } + Result _ -> reply { rResult = More right } + More parser -> reply { rResult = More $ parser *> right } + -- | Allow using the @do@ notation for our parsers, which makes for short and -- sweet @do@ syntax when we want to examine the results (we typically don't). instance Monad Parser where -- @return result@ does just that - return a /result/. - return result = Parser $ \ state -> returnReply state result + return = pure -- @left >>= right@ applies the /left/ parser, and if it didn't fail -- applies the /right/ one (well, the one /right/ returns). - left >>= right = bindParser left right - where bindParser (Parser left) right = Parser $ \ state -> - let reply = left state - in case reply|>rResult of - Failed message -> reply { rResult = Failed message } - Result value -> reply { rResult = More $ right value } - More parser -> reply { rResult = More $ bindParser parser right } + left >>= right = Parser $ \state -> + let reply = applyParser left state + in case reply^.rResult of + Failed message -> reply { rResult = Failed message } + Result value -> reply { rResult = More $ right value } + More parser -> reply { rResult = More $ parser >>= right } + (>>) = (*>) + -- @fail message@ does just that - fails with a /message/. - fail message = Parser $ \ state -> failReply state message + fail message = Parser $ \state -> failReply state message -- ** Parsing operators -- @@ -703,29 +484,46 @@ (%) :: (Match match result) => match -> Int -> Pattern parser % n | n <= 0 = empty - | n > 0 = parser & parser % n .- 1 + | n > 0 = parser' *> (parser' % n .- 1) + where + parser' = match parser -- | @parser <% n@ matches fewer than /n/ occurrences of /parser/. (<%) :: (Match match result) => match -> Int -> Pattern parser <% n | n < 1 = fail "Fewer than 0 repetitions" | n == 1 = reject parser Nothing - | n > 1 = "<%" ^ ( parser ! "<%" & parser <% n .- 1 / empty ) + | n > 1 = DeLess ^ ( ((parser ! DeLess) *> (parser <% n .- 1)) <|> empty ) +data Decision = DeNone -- "" + | DeStar -- "*" + | DeLess -- "<%" + | DeDirective + | DeDoc + | DeEscape + | DeEscaped + | DeFold + | DeKey + | DeHeader + | DeMore + | DeNode + | DePair + deriving (Show,Eq) + -- | @decision ^ (option \/ option \/ ...)@ provides a /decision/ name to the -- choice about to be made, to allow to @commit@ to it. -(^) :: (Match match result) => String -> match -> Parser result +(^) :: (Match match result) => Decision -> match -> Parser result decision ^ parser = choice decision $ match parser -- | @parser ! decision@ commits to /decision/ (in an option) after -- successfully matching the /parser/. -(!) :: (Match match result) => match -> String -> Pattern -parser ! decision = parser & commit decision +(!) :: (Match match result) => match -> Decision -> Pattern +parser ! decision = match parser *> commit decision -- | @parser ?! decision@ commits to /decision/ (in an option) if the current -- position matches /parser/, without consuming any characters. -(?!) :: (Match match result) => match -> String -> Pattern -parser ?! decision = peek parser & commit decision +(?!) :: (Match match result) => match -> Decision -> Pattern +parser ?! decision = peek parser *> commit decision -- | @lookbehind match1 -> match2 -> Parser result1 -parser - rejected = reject rejected Nothing & parser +parser - rejected = reject rejected Nothing *> match parser -- | @before & after@ parses /before/ and, if it succeeds, parses /after/. This -- basically invokes the monad's @>>=@ (bind) method. (&) :: (Match match1 result1, Match match2 result2) => match1 -> match2 -> Parser result2 -before & after = (match before) >> (match after) +before & after = match before *> match after -- | @first \/ second@ tries to parse /first/, and failing that parses -- /second/, unless /first/ has committed in which case is fails immediately. (/) :: (Match match1 result, Match match2 result) => match1 -> match2 -> Parser result -first / second = Parser $ \ state -> - let Parser parser = decide (match first) (match second) - in parser state +first / second = Parser $ applyParser (match first <|> match second) -- | @(optional ?)@ tries to match /parser/, otherwise does nothing. (?) :: (Match match result) => match -> Pattern -(?) optional = (optional & empty) / empty +(?) optional = (match optional *> empty) <|> empty -- | @(parser *)@ matches zero or more occurrences of /repeat/, as long as each -- one actually consumes input characters. (*) :: (Match match result) => match -> Pattern -(*) parser = "*" ^ zomParser - where zomParser = (parser ! "*" & zomParser) / empty +(*) parser = DeStar ^ zomParser + where + zomParser = ((parser ! DeStar) *> match zomParser) <|> empty -- | @(parser +)@ matches one or more occurrences of /parser/, as long as each -- one actually consumed input characters. (+) :: (Match match result) => match -> Pattern -(+) parser = parser & (parser *) +(+) parser = match parser *> (parser *) -- ** Basic parsers --- | @decide first second@ tries to parse /first/, and failing that parses +-- | @first <|> second@ tries to parse /first/, and failing that parses -- /second/, unless /first/ has committed in which case is fails immediately. -decide :: Parser result -> Parser result -> Parser result -decide left right = Parser $ \ state -> - let Parser parser = decideParser state D.empty left right - in parser state - where decideParser point tokens (Parser left) right = Parser $ \state -> - let reply = left state - tokens' reply = D.append tokens $ reply|>rTokens - in case (reply|>rResult, reply|>rCommit) of - (Failed _, _) -> Reply { rState = point, - rTokens = D.empty, - rResult = More right, - rCommit = Nothing } - (Result _, _) -> reply { rTokens = tokens' reply } - (More left', Just _) -> reply { rTokens = tokens' reply, - rResult = More left' } - (More left', Nothing) -> let Parser parser = decideParser point (tokens' reply) left' right - in parser $ reply|>rState +instance Alternative Parser where + empty = fail "empty" + left <|> right = Parser $ \state -> decideParser state D.empty left right state + where + decideParser point tokens left right state = + let reply = applyParser left state + tokens' = D.append tokens $ reply^.rTokens + in case (reply^.rResult, reply^.rCommit) of + (Failed _, _) -> Reply { rState = point, + rTokens = D.empty, + rResult = More right, + rCommit = Nothing } + (Result _, _) -> reply { rTokens = tokens' } + (More _, Just _) -> reply { rTokens = tokens' } + (More left', Nothing) -> decideParser point tokens' left' right (reply^.rState) + + -- | @choice decision parser@ provides a /decision/ name to the choice about to -- be made in /parser/, to allow to @commit@ to it. -choice :: String -> Parser result -> Parser result +choice :: Decision -> Parser result -> Parser result choice decision parser = Parser $ \ state -> - let Parser parser' = choiceParser (state|>sDecision) decision parser - in parser' state { sDecision = decision } - where choiceParser parentDecision makingDecision (Parser parser) = Parser $ \ state -> - let reply = parser state - commit' = case reply|>rCommit of + applyParser (choiceParser (state^.sDecision) decision parser) state { sDecision = decision } + where choiceParser parentDecision makingDecision parser = Parser $ \ state -> + let reply = applyParser parser state + commit' = case reply^.rCommit of Nothing -> Nothing Just decision | decision == makingDecision -> Nothing - | otherwise -> reply|>rCommit - reply' = case reply|>rResult of + | otherwise -> reply^.rCommit + reply' = case reply^.rResult of More parser' -> reply { rCommit = commit', rResult = More $ choiceParser parentDecision makingDecision parser' } _ -> reply { rCommit = commit', - rState = (reply|>rState) { sDecision = parentDecision } } + rState = (reply^.rState) { sDecision = parentDecision } } in reply' -- | @parser ``recovery`` pattern@ parses the specified /parser/; if it fails, -- it continues to the /recovery/ parser to recover. -recovery :: (Match match1 result, Match match2 result) => match1 -> match2 -> Parser result +recovery :: (Match match1 result) => match1 -> Parser result -> Parser result recovery pattern recover = Parser $ \ state -> - let (Parser parser) = match pattern - reply = parser state - in if state|>sIsPeek + let reply = applyParser (match pattern) state + in if state^.sIsPeek then reply - else case reply|>rResult of + else case reply^.rResult of Result _ -> reply More more -> reply { rResult = More $ more `recovery` recover } - Failed message -> reply { rResult = More $ fake Error message & unparsed & recover } - where unparsed = let (Parser parser) = match finishToken - in Parser $ \ state -> parser $ state { sCode = Unparsed } + Failed message -> reply { rResult = More $ fake Error message *> unparsed *> recover } + where unparsed = Parser $ \ state -> applyParser (match finishToken) $ state { sCode = Unparsed } -- | @prev parser@ succeeds if /parser/ matches at the previous character. It -- does not consume any input. prev :: (Match match result) => match -> Parser result prev parser = Parser $ \ state -> - prevParser state (match parser) state { sIsPeek = True, sInput = (-1, state|>sLast) : state|>sInput } - where prevParser point (Parser parser) state = - let reply = parser state - in case reply|>rResult of + prevParser state (match parser) state { sIsPeek = True, sInput = (-1, state^.sLast) : state^.sInput } + where prevParser point parser state = + let reply = applyParser parser state + in case reply^.rResult of Failed message -> failReply point message Result value -> returnReply point value - More parser' -> prevParser point parser' $ reply|>rState + More parser' -> prevParser point parser' $ reply^.rState -- | @peek parser@ succeeds if /parser/ matches at this point, but does not -- consume any input. peek :: (Match match result) => match -> Parser result peek parser = Parser $ \ state -> peekParser state (match parser) state { sIsPeek = True } - where peekParser point (Parser parser) state = - let reply = parser state - in case reply|>rResult of + where peekParser point parser state = + let reply = applyParser parser state + in case reply^.rResult of Failed message -> failReply point message Result value -> returnReply point value - More parser' -> peekParser point parser' $ reply|>rState + More parser' -> peekParser point parser' $ reply^.rState -- | @reject parser name@ fails if /parser/ matches at this point, and does -- nothing otherwise. If /name/ is provided, it is used in the error message, -- otherwise the messages uses the current character. reject :: (Match match result) => match -> Maybe String -> Pattern reject parser name = Parser $ \ state -> - rejectParser state name (match parser) state { sIsPeek = True } - where rejectParser point name (Parser parser) state = - let reply = parser state - in case reply|>rResult of - Failed _message -> returnReply point () - Result _value -> case name of - Nothing -> unexpectedReply point - Just text -> failReply point $ "Unexpected " ++ text - More parser' -> rejectParser point name parser' $ reply|>rState + rejectParser state name (match parser) state { sIsPeek = True } + where + rejectParser point name parser state = + let reply = applyParser parser state + in case reply^.rResult of + Failed _message -> returnReply point () + Result _value -> case name of + Nothing -> unexpectedReply point + Just text -> failReply point $ "Unexpected " ++ text + More parser' -> rejectParser point name parser' $ reply^.rState -- | @upto parser@ consumes all the character up to and not including the next -- point where the specified parser is a match. upto :: Pattern -> Pattern - -upto parser = ( ( parser >!) & nextIf (const True) *) +upto parser = ( ( parser >!) *> nextIf (const True) *) -- | @nonEmpty parser@ succeeds if /parser/ matches some non-empty input -- characters at this point. nonEmpty :: (Match match result) => match -> Parser result nonEmpty parser = Parser $ \ state -> - let Parser parser' = nonEmptyParser (state|>sCharOffset) (match parser) - in parser' state - where nonEmptyParser offset (Parser parser) = Parser $ \ state -> - let reply = parser state - state' = reply|>rState - in case reply|>rResult of - Failed _message -> reply - Result _value -> if state'|>sCharOffset > offset - then reply - else failReply state' "Matched empty pattern" - More parser' -> reply { rResult = More $ nonEmptyParser offset parser' } + applyParser (nonEmptyParser (state^.sCharOffset) (match parser)) state + where + nonEmptyParser offset parser = Parser $ \ state -> + let reply = applyParser parser state + state' = reply^.rState + in case reply^.rResult of + Failed _message -> reply + Result _value -> if state'^.sCharOffset > offset + then reply + else failReply state' "Matched empty pattern" + More parser' -> reply { rResult = More $ nonEmptyParser offset parser' } -- | @empty@ always matches without consuming any input. empty :: Pattern @@ -900,14 +694,14 @@ -- | @eof@ matches the end of the input. eof :: Pattern eof = Parser $ \ state -> - if state|>sInput == [] + if state^.sInput == [] then returnReply state () else unexpectedReply state -- | @sol@ matches the start of a line. sol :: Pattern sol = Parser $ \ state -> - if state|>sIsSol + if state^.sIsSol then returnReply state () else failReply state "Expected start of line" @@ -916,7 +710,7 @@ -- | @commit decision@ commits the parser to all the decisions up to the most -- recent parent /decision/. This makes all tokens generated in this parsing -- path immediately available to the caller. -commit :: String -> Pattern +commit :: Decision -> Pattern commit decision = Parser $ \ state -> Reply { rState = state, rTokens = D.empty, @@ -927,7 +721,7 @@ nextLine :: Pattern nextLine = Parser $ \ state -> returnReply state { sIsSol = True, - sLine = state|>sLine .+ 1, + sLine = state^.sLine .+ 1, sLineChar = 0 } () @@ -936,20 +730,21 @@ -- invocation, using the /setField/ and /getField/ functions to manipulate it. with :: (value -> State -> State) -> (State -> value) -> value -> Parser result -> Parser result with setField getField value parser = Parser $ \ state -> - let value' = getField state - Parser parser' = value' `seq` withParser value' parser - in parser' $ setField value state - where withParser parentValue (Parser parser) = Parser $ \ state -> - let reply = parser state - in case reply|>rResult of - Failed _ -> reply { rState = setField parentValue $ reply|>rState } - Result _ -> reply { rState = setField parentValue $ reply|>rState } - More parser' -> reply { rResult = More $ withParser parentValue parser' } + let value' = getField state + Parser parser' = value' `seq` withParser value' parser + in parser' $ setField value state + where + withParser parentValue parser = Parser $ \ state -> + let reply = applyParser parser state + in case reply^.rResult of + Failed _ -> reply { rState = setField parentValue $ reply^.rState } + Result _ -> reply { rState = setField parentValue $ reply^.rState } + More parser' -> reply { rResult = More $ withParser parentValue parser' } -- | @parser ``forbidding`` pattern@ parses the specified /parser/ ensuring -- that it does not contain anything matching the /forbidden/ parser. -forbidding :: (Match match1 result1, Match match2 result2) => match1 -> match2 -> Parser result1 -forbidding parser forbidden = with setForbidden sForbidden (Just $ forbidden & empty) (match parser) +forbidding :: (Match match1 result1) => match1 -> Parser result1 -> Parser result1 +forbidding parser forbidden = with setForbidden sForbidden (Just $ forbidden *> empty) (match parser) -- | @parser ``limitedTo`` limit@ parses the specified /parser/ -- ensuring that it does not consume more than the /limit/ input chars. @@ -963,50 +758,47 @@ -- (and buffers) the next input char if it satisfies /test/. nextIf :: (Char -> Bool) -> Pattern nextIf test = Parser $ \ state -> - case state|>sForbidden of - Nothing -> limitedNextIf state - Just parser -> let Parser parser' = reject parser $ Just "forbidden pattern" - reply = parser' state { sForbidden = Nothing } - in case reply|>rResult of - Failed _ -> reply - Result _ -> limitedNextIf state - where limitedNextIf state = - case state|>sLimit of - -1 -> consumeNextIf state - 0 -> failReply state "Lookahead limit reached" - _limit -> consumeNextIf state { sLimit = state|>sLimit .- 1 } - consumeNextIf state = - case state|>sInput of - ((offset, char):rest) | test char -> let chars = if state|>sIsPeek - then [] - else char:(state|>sChars) - byte_offset = charsOf sByteOffset sCharsByteOffset - char_offset = charsOf sCharOffset sCharsCharOffset - line = charsOf sLine sCharsLine - line_char = charsOf sLineChar sCharsLineChar - is_sol = if char == '\xFEFF' - then state|>sIsSol - else False - state' = state { sInput = rest, - sLast = char, - sChars = chars, - sCharsByteOffset = byte_offset, - sCharsCharOffset = char_offset, - sCharsLine = line, - sCharsLineChar = line_char, - sIsSol = is_sol, - sByteOffset = offset, - sCharOffset = state|>sCharOffset .+ 1, - sLineChar = state|>sLineChar .+ 1 } - in returnReply state' () - | otherwise -> unexpectedReply state - [] -> unexpectedReply state - where charsOf field charsField = if state|>sIsPeek - then -1 - else if state|>sChars == [] - then state|>field - else state|>charsField + case state^.sForbidden of + Nothing -> limitedNextIf state + Just parser -> let reply = applyParser (reject parser $ Just "forbidden pattern") state { sForbidden = Nothing } + in case reply^.rResult of + Failed _ -> reply + Result _ -> limitedNextIf state + where + limitedNextIf state = + case state^.sLimit of + -1 -> consumeNextIf state + 0 -> failReply state "Lookahead limit reached" + _limit -> consumeNextIf state { sLimit = state^.sLimit .- 1 } + consumeNextIf state = + case state^.sInput of + ((offset, char):rest) | test char -> let chars = if state^.sIsPeek then [] else char:(state^.sChars) + byte_offset = charsOf sByteOffset sCharsByteOffset + char_offset = charsOf sCharOffset sCharsCharOffset + line = charsOf sLine sCharsLine + line_char = charsOf sLineChar sCharsLineChar + is_sol = char == '\xFEFF' && state^.sIsSol + state' = state { sInput = rest, + sLast = char, + sChars = chars, + sCharsByteOffset = byte_offset, + sCharsCharOffset = char_offset, + sCharsLine = line, + sCharsLineChar = line_char, + sIsSol = is_sol, + sByteOffset = offset, + sCharOffset = state^.sCharOffset .+ 1, + sLineChar = state^.sLineChar .+ 1 } + in returnReply state' () + | otherwise -> unexpectedReply state + [] -> unexpectedReply state + where + charsOf field charsField + | state^.sIsPeek = -1 + | state^.sChars == [] = state^.field + | otherwise = state^.charsField + -- ** Producing tokens -- | @finishToken@ places all collected text into a new token and begins a new @@ -1018,15 +810,15 @@ sCharsCharOffset = -1, sCharsLine = -1, sCharsLineChar = -1 } - in if state|>sIsPeek + in if state^.sIsPeek then returnReply state' () - else case state|>sChars of + else case state^.sChars of [] -> returnReply state' () - chars@(_:_) -> tokenReply state' Token { tByteOffset = state|>sCharsByteOffset, - tCharOffset = state|>sCharsCharOffset, - tLine = state|>sCharsLine, - tLineChar = state|>sCharsLineChar, - tCode = state|>sCode, + chars@(_:_) -> tokenReply state' Token { tByteOffset = state^.sCharsByteOffset, + tCharOffset = state^.sCharsCharOffset, + tLine = state^.sCharsLine, + tLineChar = state^.sCharsLineChar, + tCode = state^.sCode, tText = reverse chars } -- | @wrap parser@ invokes the /parser/, ensures any unclaimed input characters @@ -1048,7 +840,7 @@ -- /text/ characters, instead of whatever characters are collected so far. fake :: Code -> String -> Pattern fake code text = Parser $ \ state -> - if state|>sIsPeek + if state^.sIsPeek then returnReply state () else tokenReply state Token { tByteOffset = value state sByteOffset sCharsByteOffset, tCharOffset = value state sCharOffset sCharsCharOffset, @@ -1080,12 +872,12 @@ emptyToken :: Code -> Pattern emptyToken code = finishToken & parser code where parser code = Parser $ \ state -> - if state|>sIsPeek + if state^.sIsPeek then returnReply state () - else tokenReply state Token { tByteOffset = state|>sByteOffset, - tCharOffset = state|>sCharOffset, - tLine = state|>sLine, - tLineChar = state|>sLineChar, + else tokenReply state Token { tByteOffset = state^.sByteOffset, + tCharOffset = state^.sCharOffset, + tLine = state^.sLine, + tLineChar = state^.sLineChar, tCode = code, tText = "" } @@ -1101,12 +893,11 @@ prefixErrorWith :: (Match match result) => match -> Pattern -> Parser result prefixErrorWith pattern prefix = Parser $ \ state -> - let (Parser parser) = match pattern - reply = parser state - in case reply|>rResult of - Result _ -> reply - More more -> reply { rResult = More $ prefixErrorWith more prefix } - Failed message -> reply { rResult = More $ prefix & (fail message :: Parser result) } + let reply = applyParser (match pattern) state + in case reply^.rResult of + Result _ -> reply + More more -> reply { rResult = More $ prefixErrorWith more prefix } + Failed message -> reply { rResult = More $ prefix & (fail message :: Parser result) } -- * Production parameters @@ -1179,15 +970,16 @@ -- | @patternTokenizer pattern@ converts the /pattern/ to a simple 'Tokenizer'. patternTokenizer :: Pattern -> Tokenizer patternTokenizer pattern input withFollowing = - D.toList $ patternParser (wrap pattern) (initialState input) - where patternParser (Parser parser) state = - let reply = parser state - tokens = commitBugs reply - state' = reply|>rState - in case reply|>rResult of - Failed message -> errorTokens tokens state' message withFollowing - Result _ -> tokens - More parser' -> D.append tokens $ patternParser parser' state' + D.toList $ patternParser (wrap pattern) (initialState input) + where + patternParser parser state = + let reply = applyParser parser state + tokens = commitBugs reply + state' = reply^.rState + in case reply^.rResult of + Failed message -> errorTokens tokens state' message withFollowing + Result _ -> tokens + More parser' -> D.append tokens $ patternParser parser' state' -- | @errorTokens tokens state message withFollowing@ appends an @Error@ token -- with the specified /message/ at the end of /tokens/, and if /withFollowing/ @@ -1195,39 +987,39 @@ -- token. errorTokens :: D.DList Token -> State -> String -> Bool -> D.DList Token errorTokens tokens state message withFollowing = - let tokens' = D.append tokens $ D.singleton Token { tByteOffset = state|>sByteOffset, - tCharOffset = state|>sCharOffset, - tLine = state|>sLine, - tLineChar = state|>sLineChar, + let tokens' = D.append tokens $ D.singleton Token { tByteOffset = state^.sByteOffset, + tCharOffset = state^.sCharOffset, + tLine = state^.sLine, + tLineChar = state^.sLineChar, tCode = Error, tText = message } - in if withFollowing && state|>sInput /= [] - then D.append tokens' $ D.singleton Token { tByteOffset = state|>sByteOffset, - tCharOffset = state|>sCharOffset, - tLine = state|>sLine, - tLineChar = state|>sLineChar, + in if withFollowing && state^.sInput /= [] + then D.append tokens' $ D.singleton Token { tByteOffset = state^.sByteOffset, + tCharOffset = state^.sCharOffset, + tLine = state^.sLine, + tLineChar = state^.sLineChar, tCode = Unparsed, - tText = map snd $ state|>sInput } + tText = map snd $ state^.sInput } else tokens' -- | @commitBugs reply@ inserts an error token if a commit was made outside a -- named choice. This should never happen outside tests. commitBugs :: Reply result -> D.DList Token commitBugs reply = - let tokens = reply|>rTokens - state = reply|>rState - in case reply|>rCommit of + let tokens = reply^.rTokens + state = reply^.rState + in case reply^.rCommit of Nothing -> tokens - Just commit -> D.append tokens $ D.singleton Token { tByteOffset = state|>sByteOffset, - tCharOffset = state|>sCharOffset, - tLine = state|>sLine, - tLineChar = state|>sLineChar, + Just commit -> D.append tokens $ D.singleton Token { tByteOffset = state^.sByteOffset, + tCharOffset = state^.sCharOffset, + tLine = state^.sLine, + tLineChar = state^.sLineChar, tCode = Error, - tText = "Commit to '" ++ commit ++ "' was made outside it" } + tText = "Commit to " ++ show commit ++ " was made outside it" } --- | @'tokenize' input emit_unparsed@ --- converts the Unicode /input/ to a --- list of 'Token' according to the YAML 1.2 specification. +-- | @'tokenize' input emit_unparsed@ converts the Unicode /input/ +-- (using the UTF-8, UTF-16 (LE or BE), or UTF-32 (LE or BE) encoding) +-- to a list of 'Token' according to the YAML 1.2 specification. -- -- Errors are reported as tokens with @'Error' :: 'Code'@, and the -- unparsed text following an error may be attached as a final 'Unparsed' token @@ -1246,14 +1038,13 @@ -- reports the encoding (which was already detected when we started parsing). bom :: Match match1 result1 => match1 -> Parser () bom code = code - & (Parser $ \ state -> let text = case state|>sEncoding of + & (Parser $ \ state -> let text = case state^.sEncoding of UTF8 -> "TF-8" UTF16LE -> "TF-16LE" UTF16BE -> "TF-16BE" UTF32LE -> "TF-32LE" UTF32BE -> "TF-32BE" - Parser parser = fake Bom text - in parser state) + in applyParser (fake Bom text) state) -- | @na@ is the \"non-applicable\" indentation value. We use Haskell's laziness -- to verify it really is never used. @@ -1263,7 +1054,7 @@ -- | @asInteger@ returns the last consumed character, which is assumed to be a -- decimal digit, as an integer. asInteger :: Parser Int -asInteger = Parser $ \ state -> returnReply state $ ord (state|>sLast) .- 48 +asInteger = Parser $ \ state -> returnReply state $ ord (state^.sLast) .- 48 -- | @result value@ is the same as /return value/ except that we give the -- Haskell type deduction the additional boost it needs to figure out this is @@ -1362,8 +1153,8 @@ ns_word_char {- 38 -} = ns_dec_digit / ns_ascii_letter / '-' -ns_uri_char {- 39 -} = "escape" - ^ ( '%' ! "escape" & ns_hex_digit & ns_hex_digit / ns_word_char / '#' +ns_uri_char {- 39 -} = DeEscape + ^ ( '%' ! DeEscape & ns_hex_digit & ns_hex_digit / ns_word_char / '#' / ';' / '/' / '?' / ':' / '@' / '&' / '=' / '+' / '$' / ',' / '_' / '.' / '!' / '~' / '*' / '\'' / '(' / ')' / '[' / ']' ) @@ -1390,13 +1181,13 @@ ns_esc_non_breaking_space {- 56 -} = meta '_' ns_esc_line_separator {- 57 -} = meta 'L' ns_esc_paragraph_separator {- 58 -} = meta 'P' -ns_esc_8_bit {- 59 -} = indicator 'x' ! "escaped" & meta ( ns_hex_digit % 2 ) -ns_esc_16_bit {- 60 -} = indicator 'u' ! "escaped" & meta ( ns_hex_digit % 4 ) -ns_esc_32_bit {- 61 -} = indicator 'U' ! "escaped" & meta ( ns_hex_digit % 8 ) +ns_esc_8_bit {- 59 -} = indicator 'x' ! DeEscaped & meta ( ns_hex_digit % 2 ) +ns_esc_16_bit {- 60 -} = indicator 'u' ! DeEscaped & meta ( ns_hex_digit % 4 ) +ns_esc_32_bit {- 61 -} = indicator 'U' ! DeEscaped & meta ( ns_hex_digit % 8 ) c_ns_esc_char {- 62 -} = wrapTokens BeginEscape EndEscape - $ c_escape ! "escape" - & "escaped" + $ c_escape ! DeEscape + & DeEscaped ^ ( ns_esc_null / ns_esc_bell / ns_esc_backspace / ns_esc_horizontal_tab / ns_esc_line_feed / ns_esc_vertical_tab / ns_esc_form_feed @@ -1474,8 +1265,8 @@ -- 6.8 Directives l_directive {- 82 -} = ( wrapTokens BeginDirective EndDirective - $ c_directive ! "doc" - & "directive" + $ c_directive ! DeDoc + & DeDirective ^ ( ns_yaml_directive / ns_tag_directive / ns_reserved_directive ) ) @@ -1488,13 +1279,13 @@ -- 6.8.1 Yaml Directives -ns_yaml_directive {- 86 -} = meta [ 'Y', 'A', 'M', 'L' ] ! "directive" +ns_yaml_directive {- 86 -} = meta [ 'Y', 'A', 'M', 'L' ] ! DeDirective & s_separate_in_line & ns_yaml_version ns_yaml_version {- 87 -} = meta ( ( ns_dec_digit +) & '.' & ( ns_dec_digit +) ) -- 6.8.2 Tag Directives -ns_tag_directive {- 88 -} = meta [ 'T', 'A', 'G' ] ! "directive" +ns_tag_directive {- 88 -} = meta [ 'T', 'A', 'G' ] ! DeDirective & s_separate_in_line & c_tag_handle & s_separate_in_line & ns_tag_prefix @@ -1554,7 +1345,7 @@ -- 7.1 Alias Nodes c_ns_alias_node {- 104 -} = wrapTokens BeginAlias EndAlias - $ c_alias ! "node" & ns_anchor_name + $ c_alias ! DeNode & ns_anchor_name -- 7.2 Empty Nodes @@ -1564,11 +1355,11 @@ -- 7.3.1 Double Quoted Style -nb_double_char {- 107 -} = "escape" ^ ( c_ns_esc_char / ( nb_json - c_escape - c_double_quote ) ) +nb_double_char {- 107 -} = DeEscape ^ ( c_ns_esc_char / ( nb_json - c_escape - c_double_quote ) ) ns_double_char {- 108 -} = nb_double_char - s_white c_double_quoted n c {- 109 -} = wrapTokens BeginScalar EndScalar - $ c_double_quote ! "node" & text ( nb_double_text n c ) & c_double_quote + $ c_double_quote ! DeNode & text ( nb_double_text n c ) & c_double_quote nb_double_text n c {- 110 -} = case c of FlowOut -> nb_double_multi_line n FlowIn -> nb_double_multi_line n @@ -1577,10 +1368,10 @@ nb_double_one_line {- 111 -} = ( nb_double_char *) s_double_escaped n {- 112 -} = ( s_white *) - & wrapTokens BeginEscape EndEscape ( c_escape ! "escape" & b_non_content ) + & wrapTokens BeginEscape EndEscape ( c_escape ! DeEscape & b_non_content ) & ( l_empty n FlowIn *) & s_flow_line_prefix n -s_double_break n {- 113 -} = "escape" ^ ( s_double_escaped n / s_flow_folded n ) +s_double_break n {- 113 -} = DeEscape ^ ( s_double_escaped n / s_flow_folded n ) nb_ns_double_in_line {- 114 -} = ( ( s_white *) & ns_double_char *) s_double_next_line n {- 115 -} = s_double_break n @@ -1592,12 +1383,12 @@ -- 7.3.2 Single Quoted Style c_quoted_quote {- 117 -} = wrapTokens BeginEscape EndEscape - $ c_single_quote ! "escape" & meta '\'' -nb_single_char {- 118 -} = "escape" ^ ( c_quoted_quote / ( nb_json - c_single_quote ) ) + $ c_single_quote ! DeEscape & meta '\'' +nb_single_char {- 118 -} = DeEscape ^ ( c_quoted_quote / ( nb_json - c_single_quote ) ) ns_single_char {- 119 -} = nb_single_char - s_white c_single_quoted n c {- 120 -} = wrapTokens BeginScalar EndScalar - $ c_single_quote ! "node" & text ( nb_single_text n c ) & c_single_quote + $ c_single_quote ! DeNode & text ( nb_single_text n c ) & c_single_quote nb_single_text n c {- 121 -} = case c of FlowOut -> nb_single_multi_line n FlowIn -> nb_single_multi_line n @@ -1635,7 +1426,7 @@ BlockKey -> ns_plain_one_line c FlowKey -> ns_plain_one_line c) nb_ns_plain_in_line c {- 132 -} = ( ( s_white *) & ns_plain_char c *) -ns_plain_one_line c {- 133 -} = ns_plain_first c ! "node" & nb_ns_plain_in_line c +ns_plain_one_line c {- 133 -} = ns_plain_first c ! DeNode & nb_ns_plain_in_line c s_ns_plain_next_line n c {- 134 -} = s_flow_folded n & ns_plain_char c & nb_ns_plain_in_line c @@ -1653,59 +1444,59 @@ -- 7.4.1 Flow Sequences c_flow_sequence n c {- 137 -} = wrapTokens BeginSequence EndSequence - $ c_sequence_start ! "node" & ( s_separate n c ?) + $ c_sequence_start ! DeNode & ( s_separate n c ?) & ( ns_s_flow_seq_entries n (in_flow c) ?) & c_sequence_end ns_s_flow_seq_entries n c {- 138 -} = ns_flow_seq_entry n c & ( s_separate n c ?) & ( c_collect_entry & ( s_separate n c ?) & ( ns_s_flow_seq_entries n c ?) ?) -ns_flow_seq_entry n c {- 139 -} = "pair" ^ ( ns_flow_pair n c / "node" ^ ns_flow_node n c ) +ns_flow_seq_entry n c {- 139 -} = DePair ^ ( ns_flow_pair n c / DeNode ^ ns_flow_node n c ) -- 7.4.2 Flow Mappings c_flow_mapping n c {- 140 -} = wrapTokens BeginMapping EndMapping - $ c_mapping_start ! "node" & ( s_separate n c ?) + $ c_mapping_start ! DeNode & ( s_separate n c ?) & ( ns_s_flow_map_entries n (in_flow c) ?) & c_mapping_end ns_s_flow_map_entries n c {- 141 -} = ns_flow_map_entry n c & ( s_separate n c ?) & ( c_collect_entry & ( s_separate n c ?) & ( ns_s_flow_map_entries n c ?) ?) ns_flow_map_entry n c {- 142 -} = wrapTokens BeginPair EndPair - $ "key" ^ ( ( c_mapping_key ! "key" & s_separate n c + $ DeKey ^ ( ( c_mapping_key ! DeKey & s_separate n c & ns_flow_map_explicit_entry n c ) / ns_flow_map_implicit_entry n c ) ns_flow_map_explicit_entry n c {- 143 -} = ns_flow_map_implicit_entry n c / ( e_node & e_node ) -ns_flow_map_implicit_entry n c {- 144 -} = "pair" +ns_flow_map_implicit_entry n c {- 144 -} = DePair ^ ( ns_flow_map_yaml_key_entry n c / c_ns_flow_map_empty_key_entry n c / c_ns_flow_map_json_key_entry n c ) -ns_flow_map_yaml_key_entry n c {- 145 -} = ( "node" ^ ns_flow_yaml_node n c ) ! "pair" +ns_flow_map_yaml_key_entry n c {- 145 -} = ( DeNode ^ ns_flow_yaml_node n c ) ! DePair & ( ( ( s_separate n c ?) & c_ns_flow_map_separate_value n c ) / e_node ) c_ns_flow_map_empty_key_entry n c {- 146 -} = e_node & c_ns_flow_map_separate_value n c -c_ns_flow_map_separate_value n c {- 147 -} = c_mapping_value & ( ns_char >!) ! "pair" +c_ns_flow_map_separate_value n c {- 147 -} = c_mapping_value & ( ns_char >!) ! DePair & ( ( s_separate n c & ns_flow_node n c ) / e_node ) -c_ns_flow_map_json_key_entry n c {- 148 -} = ( "node" ^ c_flow_json_node n c ) ! "pair" +c_ns_flow_map_json_key_entry n c {- 148 -} = ( DeNode ^ c_flow_json_node n c ) ! DePair & ( ( ( s_separate n c ?) & c_ns_flow_map_adjacent_value n c ) / e_node ) -c_ns_flow_map_adjacent_value n c {- 149 -} = c_mapping_value ! "pair" +c_ns_flow_map_adjacent_value n c {- 149 -} = c_mapping_value ! DePair & ( ( ( s_separate n c ?) & ns_flow_node n c ) / e_node ) ns_flow_pair n c {- 150 -} = wrapTokens BeginMapping EndMapping $ wrapTokens BeginPair EndPair - $ ( ( c_mapping_key ! "pair" & s_separate n c + $ ( ( c_mapping_key ! DePair & s_separate n c & ns_flow_map_explicit_entry n c ) / ns_flow_pair_entry n c ) @@ -1716,9 +1507,9 @@ & c_ns_flow_map_separate_value n c c_ns_flow_pair_json_key_entry n c {- 153 -} = c_s_implicit_json_key FlowKey & c_ns_flow_map_adjacent_value n c -ns_s_implicit_yaml_key c {- 154 -} = ( "node" ^ ( ns_flow_yaml_node na c ) & ( s_separate_in_line ?) ) +ns_s_implicit_yaml_key c {- 154 -} = ( DeNode ^ ( ns_flow_yaml_node na c ) & ( s_separate_in_line ?) ) `limitedTo` 1024 -c_s_implicit_json_key c {- 155 -} = ( "node" ^ ( c_flow_json_node na c ) & ( s_separate_in_line ?) ) +c_s_implicit_json_key c {- 155 -} = ( DeNode ^ ( c_flow_json_node na c ) & ( s_separate_in_line ?) ) `limitedTo` 1024 -- 7.5 Flow Nodes @@ -1746,10 +1537,10 @@ -- 8.1.1 Block Scalar Headers -c_b_block_header n {- 162 -} = "header" +c_b_block_header n {- 162 -} = DeHeader ^ ( do m <- c_indentation_indicator n t <- c_chomping_indicator - ( s_white / b_char ) ?! "header" + ( s_white / b_char ) ?! DeHeader s_b_comment result (m, t) / do t <- c_chomping_indicator @@ -1759,11 +1550,16 @@ -- 8.1.1.1 Block Indentation Indicator -c_indentation_indicator n {- 163 -} = indicator ( ns_dec_digit - '0' ) & asInteger +c_indentation_indicator n {- 163 -} = fmap fixup (indicator ( ns_dec_digit - '0' ) & asInteger) / detect_scalar_indentation n + where + fixup | n == -1 = (.+ 1) -- compensate for anomaly at left-most n + | otherwise = id detect_scalar_indentation n = peek $ ( nb_char *) - & ( b_non_content & ( l_empty n BlockIn *) ?) + -- originally: + -- & ( b_non_content & ( l_empty n BlockIn *) ?) + & ( b_break & ( (s_space *) & b_break *) ?) & count_spaces (-n) count_spaces n = (s_space & count_spaces (n .+ 1)) @@ -1801,7 +1597,7 @@ -- 8.1.2 Literal Style c_l__literal n {- 170 -} = do emptyToken BeginScalar - c_literal ! "node" + c_literal ! DeNode (m, t) <- c_b_block_header n `prefixErrorWith` emptyToken EndScalar text ( l_literal_content (n .+ m) t ) @@ -1816,22 +1612,22 @@ -- 8.1.3 Folded Style c_l__folded n {- 174 -} = do emptyToken BeginScalar - c_folded ! "node" + c_folded ! DeNode (m, t) <- c_b_block_header n `prefixErrorWith` emptyToken EndScalar text ( l_folded_content (n .+ m) t ) -s_nb_folded_text n {- 175 -} = s_indent n & ns_char ! "fold" & ( nb_char *) +s_nb_folded_text n {- 175 -} = s_indent n & ns_char ! DeFold & ( nb_char *) l_nb_folded_lines n {- 176 -} = s_nb_folded_text n & ( b_l_folded n BlockIn & s_nb_folded_text n *) -s_nb_spaced_text n {- 177 -} = s_indent n & s_white ! "fold" & ( nb_char *) +s_nb_spaced_text n {- 177 -} = s_indent n & s_white ! DeFold & ( nb_char *) b_l_spaced n {- 178 -} = b_as_line_feed & ( l_empty n BlockIn *) l_nb_spaced_lines n {- 179 -} = s_nb_spaced_text n & ( b_l_spaced n & s_nb_spaced_text n *) l_nb_same_lines n {- 180 -} = ( l_empty n BlockIn *) - & "fold" ^ ( l_nb_folded_lines n / l_nb_spaced_lines n ) + & DeFold ^ ( l_nb_folded_lines n / l_nb_spaced_lines n ) l_nb_diff_lines n {- 181 -} = l_nb_same_lines n & ( b_as_line_feed & l_nb_same_lines n *) @@ -1847,11 +1643,11 @@ l__block_sequence n {- 183 -} = do m <- detect_collection_indentation n wrapTokens BeginSequence EndSequence $ ( s_indent (n .+ m) & c_l_block_seq_entry (n .+ m) +) -c_l_block_seq_entry n {- 184 -} = c_sequence_entry & ( ns_char >!) ! "node" +c_l_block_seq_entry n {- 184 -} = c_sequence_entry & ( ns_char >!) ! DeNode & s_l__block_indented n BlockIn s_l__block_indented n c {- 185 -} = do m <- detect_inline_indentation - "node" ^ ( ( s_indent m + DeNode ^ ( ( s_indent m & ( ns_l_in_line_sequence (n .+ 1 .+ m) / ns_l_in_line_mapping (n .+ 1 .+ m) ) ) / s_l__block_node n c @@ -1872,7 +1668,7 @@ c_l_block_map_explicit_entry n {- 189 -} = c_l_block_map_explicit_key n & ( l_block_map_explicit_value n / e_node ) -c_l_block_map_explicit_key n {- 190 -} = c_mapping_key ! "node" & s_l__block_indented n BlockOut +c_l_block_map_explicit_key n {- 190 -} = c_mapping_key ! DeNode & s_l__block_indented n BlockOut l_block_map_explicit_value n {- 191 -} = s_indent n & c_mapping_value & s_l__block_indented n BlockOut ns_l_block_map_implicit_entry n {- 192 -} = ( ns_s_block_map_implicit_key @@ -1881,7 +1677,7 @@ ns_s_block_map_implicit_key {- 193 -} = c_s_implicit_json_key BlockKey / ns_s_implicit_yaml_key BlockKey -c_l_block_map_implicit_value n {- 194 -} = c_mapping_value ! "node" +c_l_block_map_implicit_value n {- 194 -} = c_mapping_value ! DeNode & ( ( s_l__block_node n BlockOut / ( e_node & ( s_l_comments ?) & unparsed (n .+ 1) ) ) `recovery` unparsed (n .+ 1) ) @@ -1931,12 +1727,12 @@ -- 9.1.3 Explicit Documents -l_bare_document {- 207 -} = "node" ^ s_l__block_node (-1) BlockIn +l_bare_document {- 207 -} = DeNode ^ s_l__block_node (-1) BlockIn `forbidding` c_forbidden -- 9.1.4 Explicit Documents -l_explicit_document {- 208 -} = c_directives_end ! "doc" +l_explicit_document {- 208 -} = ( c_directives_end & ( b_char / s_white / eof >?)) ! DeDoc & ( ( l_bare_document / e_node & ( s_l_comments ?) & unparsed 0 ) `recovery` unparsed 0 ) @@ -1948,11 +1744,11 @@ -- 9.2 Streams: l_any_document {- 210 -} = wrapTokens BeginDocument EndDocument - $ "doc" ^ ( l_directives_document + $ DeDoc ^ ( l_directives_document / l_explicit_document / l_bare_document ) `recovery` unparsed 0 l_yaml_stream {- 211 -} = ( nonEmpty l_document_prefix *) & ( eof / ( c_document_end & ( b_char / s_white / eof ) >?) / l_any_document ) - & ( nonEmpty ( "more" ^ ( ( l_document_suffix ! "more" +) & ( nonEmpty l_document_prefix *) & ( eof / l_any_document ) - / ( nonEmpty l_document_prefix *) & "doc" ^ ( wrapTokens BeginDocument EndDocument l_explicit_document ?) ) ) *) + & ( nonEmpty ( DeMore ^ ( ( l_document_suffix ! DeMore +) & ( nonEmpty l_document_prefix *) & ( eof / l_any_document ) + / ( nonEmpty l_document_prefix *) & DeDoc ^ ( wrapTokens BeginDocument EndDocument l_explicit_document ?) ) ) *) diff --git a/src/Data/YAML/Token/Encoding.hs b/src/Data/YAML/Token/Encoding.hs new file mode 100644 --- /dev/null +++ b/src/Data/YAML/Token/Encoding.hs @@ -0,0 +1,256 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE Safe #-} + +-- | +-- Copyright: © Oren Ben-Kiki 2007, +-- © Herbert Valerio Riedel 2015-2018 +-- SPDX-License-Identifier: GPL-3.0 +-- +-- UTF decoding +-- +-- This really should be factored out to the standard libraries. Since it isn't +-- there, we get to tailor it exactly to our needs. We use lazy byte strings as +-- input, which should give reasonable I\/O performance when reading large +-- files. The output is a normal 'Char' list which is easy to work with and +-- should be efficient enough as long as the 'Parser' does its job right. +-- +module Data.YAML.Token.Encoding + ( decode + , Encoding(..) + ) where + +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Char8 as BLC + +import Util + +-- | Recognized Unicode encodings. As of YAML 1.2 UTF-32 is also required. +data Encoding = UTF8 -- ^ UTF-8 encoding (or ASCII) + | UTF16LE -- ^ UTF-16 little endian + | UTF16BE -- ^ UTF-16 big endian + | UTF32LE -- ^ UTF-32 little endian + | UTF32BE -- ^ UTF-32 big endian + +-- | @show encoding@ converts an 'Encoding' to the encoding name (with a "-") +-- as used by most programs. +instance Show Encoding where + show UTF8 = "UTF-8" + show UTF16LE = "UTF-16LE" + show UTF16BE = "UTF-16BE" + show UTF32LE = "UTF-32LE" + show UTF32BE = "UTF-32BE" + +-- | @decode bytes@ automatically detects the 'Encoding' used and converts the +-- /bytes/ to Unicode characters, with byte offsets. Note the offset is for +-- past end of the character, not its beginning. +decode :: BLC.ByteString -> (Encoding, [(Int, Char)]) +decode text = (encoding, undoEncoding encoding text) + where encoding = detectEncoding $ BLC.unpack $ BLC.take 4 text + +-- | @detectEncoding text@ examines the first few chars (bytes) of the /text/ +-- to deduce the Unicode encoding used according to the YAML spec. +detectEncoding :: [Char] -> Encoding +detectEncoding text = + case text of + '\x00' : '\x00' : '\xFE' : '\xFF' : _ -> UTF32BE + '\x00' : '\x00' : '\x00' : _ : _ -> UTF32BE + '\xFF' : '\xFE' : '\x00' : '\x00' : _ -> UTF32LE + _ : '\x00' : '\x00' : '\x00' : _ -> UTF32LE + '\xFE' : '\xFF' : _ -> UTF16BE + '\x00' : _ : _ -> UTF16BE + '\xFF' : '\xFE' : _ -> UTF16LE + _ : '\x00' : _ -> UTF16LE + '\xEF' : '\xBB' : '\xBF' : _ -> UTF8 + _ -> UTF8 + +-- | @undoEncoding encoding bytes@ converts a /bytes/ stream to Unicode +-- characters according to the /encoding/. +undoEncoding :: Encoding -> BLC.ByteString -> [(Int, Char)] +undoEncoding encoding bytes = + case encoding of + UTF8 -> undoUTF8 bytes 0 + UTF16LE -> combinePairs $ undoUTF16LE bytes 0 + UTF16BE -> combinePairs $ undoUTF16BE bytes 0 + UTF32LE -> validateScalars $ undoUTF32LE bytes 0 + UTF32BE -> validateScalars $ undoUTF32BE bytes 0 + where + validateScalars [] = [] + validateScalars (x@(_,c):rest) + | '\xD800' <= c, c <= '\xDFFF' = error "UTF-32 stream contains invalid surrogate code-point" + | otherwise = x : validateScalars rest + +-- ** UTF-32 decoding + +-- | @hasFewerThan bytes n@ checks whether there are fewer than /n/ /bytes/ +-- left to read. +hasFewerThan :: Int -> BLC.ByteString -> Bool +hasFewerThan n bytes + | n == 1 = BLC.null bytes + | n > 1 = BLC.null bytes || hasFewerThan (n - 1) (BLC.tail bytes) + | otherwise = False + +-- | @undoUTF32LE bytes offset@ decoded a UTF-32LE /bytes/ stream to Unicode +-- chars. +undoUTF32LE :: BLC.ByteString -> Int -> [(Int, Char)] +undoUTF32LE bytes offset + | BLC.null bytes = [] + | hasFewerThan 4 bytes = error "UTF-32LE input contains invalid number of bytes" + | otherwise = let first = BLC.head bytes + bytes' = BLC.tail bytes + second = BLC.head bytes' + bytes'' = BLC.tail bytes' + third = BLC.head bytes'' + bytes''' = BLC.tail bytes'' + fourth = BLC.head bytes''' + rest = BLC.tail bytes''' + in (offset + 4, + chr $ (ord first) + + 256 * ((ord second) + + 256 * ((ord third) + + 256 * ((ord fourth))))):(undoUTF32LE rest $ offset + 4) + +-- | @undoUTF32BE bytes offset@ decoded a UTF-32BE /bytes/ stream to Unicode +-- chars. +undoUTF32BE :: BLC.ByteString -> Int -> [(Int, Char)] +undoUTF32BE bytes offset + | BLC.null bytes = [] + | hasFewerThan 4 bytes = error "UTF-32BE input contains invalid number of bytes" + | otherwise = let first = BLC.head bytes + bytes' = BLC.tail bytes + second = BLC.head bytes' + bytes'' = BLC.tail bytes' + third = BLC.head bytes'' + bytes''' = BLC.tail bytes'' + fourth = BLC.head bytes''' + rest = BLC.tail bytes''' + in (offset + 4, + chr $ (ord fourth) + + 256 * ((ord third) + + 256 * ((ord second) + + 256 * ((ord first))))):(undoUTF32BE rest $ offset + 4) + +-- ** UTF-16 decoding + +-- | @combinePairs chars@ converts each pair of UTF-16 surrogate characters to a +-- single Unicode character. +combinePairs :: [(Int, Char)] -> [(Int, Char)] +combinePairs [] = [] +combinePairs (head'@(_, head_char):tail') + | '\xD800' <= head_char && head_char <= '\xDBFF' = combineLead head' tail' + | '\xDC00' <= head_char && head_char <= '\xDFFF' = error "UTF-16 contains trail surrogate without lead surrogate" + | otherwise = head':(combinePairs tail') + +-- | @combineLead lead rest@ combines the /lead/ surrogate with the head of the +-- /rest/ of the input chars, assumed to be a /trail/ surrogate, and continues +-- combining surrogate pairs. +combineLead :: (Int, Char) -> [(Int, Char)] -> [(Int, Char)] +combineLead _lead [] = error "UTF-16 contains lead surrogate as final character" +combineLead (_, lead_char) ((trail_offset, trail_char):rest) + | '\xDC00' <= trail_char && trail_char <= '\xDFFF' = (trail_offset, combineSurrogates lead_char trail_char):combinePairs rest + | otherwise = error "UTF-16 contains lead surrogate without trail surrogate" + +-- | @surrogateOffset@ is copied from the Unicode FAQs. +surrogateOffset :: Int +surrogateOffset = 0x10000 - (0xD800 * 1024) - 0xDC00 + +-- | @combineSurrogates lead trail@ combines two UTF-16 surrogates into a single +-- Unicode character. +combineSurrogates :: Char -> Char -> Char +combineSurrogates lead trail = chr $ (ord lead) * 1024 + (ord trail) + surrogateOffset + +-- | @undoUTF18LE bytes offset@ decoded a UTF-16LE /bytes/ stream to Unicode +-- chars. +undoUTF16LE :: BLC.ByteString -> Int -> [(Int, Char)] +undoUTF16LE bytes offset + | BLC.null bytes = [] + | hasFewerThan 2 bytes = error "UTF-16LE input contains odd number of bytes" + | otherwise = let low = BLC.head bytes + bytes' = BLC.tail bytes + high = BLC.head bytes' + rest = BLC.tail bytes' + in (offset + 2, chr $ (ord low) + (ord high) * 256):(undoUTF16LE rest $ offset + 2) + +-- | @undoUTF18BE bytes offset@ decoded a UTF-16BE /bytes/ stream to Unicode +-- chars. +undoUTF16BE :: BLC.ByteString -> Int -> [(Int, Char)] +undoUTF16BE bytes offset + | BLC.null bytes = [] + | hasFewerThan 2 bytes = error "UTF-16BE input contains odd number of bytes" + | otherwise = let high = BLC.head bytes + bytes' = BLC.tail bytes + low = BLC.head bytes' + rest = BLC.tail bytes' + in (offset + 2, chr $ (ord low) + (ord high) * 256):(undoUTF16BE rest $ offset + 2) + +-- ** UTF-8 decoding + +-- | @undoUTF8 bytes offset@ decoded a UTF-8 /bytes/ stream to Unicode chars. +undoUTF8 :: BLC.ByteString -> Int -> [(Int, Char)] +undoUTF8 bytes offset = undoUTF8' (BL.unpack bytes) offset + +w2c :: Word8 -> Char +w2c = chr . fromIntegral + +w2i :: Word8 -> Int +w2i = fromIntegral + +undoUTF8' :: [Word8] -> Int -> [(Int, Char)] +undoUTF8' [] _ = [] +undoUTF8' (first:rest) !offset + | first < 0x80 = (offset', c) : undoUTF8' rest offset' + where + !offset' = offset + 1 + !c = w2c first +undoUTF8' (first:rest) !offset + | first < 0xC0 = error "UTF-8 input contains invalid first byte" + | first < 0xE0 = decodeTwoUTF8 first offset rest + | first < 0xF0 = decodeThreeUTF8 first offset rest + | first < 0xF8 = decodeFourUTF8 first offset rest + | otherwise = error "UTF-8 input contains invalid first byte" + +-- | @decodeTwoUTF8 first offset bytes@ decodes a two-byte UTF-8 character, +-- where the /first/ byte is already available and the second is the head of +-- the /bytes/, and then continues to undo the UTF-8 encoding. +decodeTwoUTF8 :: Word8 -> Int -> [Word8] -> [(Int, Char)] +decodeTwoUTF8 first offset (second:rest) + | second < 0x80 || 0xBF < second = error $ "UTF-8 double byte char has invalid second byte" + | otherwise = (offset', c) : undoUTF8' rest offset' + where + !offset' = offset + 2 + !c = chr ((w2i first - 0xc0) * 0x40 + (w2i second - 0x80)) +decodeTwoUTF8 _ _ [] = error "UTF-8 double byte char is missing second byte at eof" + +-- | @decodeThreeUTF8 first offset bytes@ decodes a three-byte UTF-8 character, +-- where the /first/ byte is already available and the second and third are the +-- head of the /bytes/, and then continues to undo the UTF-8 encoding. +decodeThreeUTF8 :: Word8 -> Int -> [Word8] -> [(Int, Char)] +decodeThreeUTF8 first offset (second:third:rest) + | second < 0x80 || 0xBF < second = error "UTF-8 triple byte char has invalid second byte" + | third < 0x80 || 0xBF < third = error "UTF-8 triple byte char has invalid third byte" + | otherwise = (offset', c): undoUTF8' rest offset' + where + !offset' = offset + 3 + !c = chr(((w2i first) - 0xE0) * 0x1000 + + ((w2i second) - 0x80) * 0x40 + + ((w2i third) - 0x80)) +decodeThreeUTF8 _ _ _ =error "UTF-8 triple byte char is missing bytes at eof" + +-- | @decodeFourUTF8 first offset bytes@ decodes a four-byte UTF-8 character, +-- where the /first/ byte is already available and the second, third and fourth +-- are the head of the /bytes/, and then continues to undo the UTF-8 encoding. +decodeFourUTF8 :: Word8 -> Int -> [Word8] -> [(Int, Char)] +decodeFourUTF8 first offset (second:third:fourth:rest) + | second < 0x80 || 0xBF < second = error "UTF-8 quad byte char has invalid second byte" + | third < 0x80 || 0xBF < third = error "UTF-8 quad byte char has invalid third byte" + | third < 0x80 || 0xBF < third = error "UTF-8 quad byte char has invalid fourth byte" + | otherwise = (offset', c) : undoUTF8' rest offset' + where + !offset' = offset + 4 + !c = chr(((w2i first) - 0xF0) * 0x40000 + + ((w2i second) - 0x80) * 0x1000 + + ((w2i third) - 0x80) * 0x40 + + ((w2i fourth) - 0x80)) + +decodeFourUTF8 _ _ _ = error "UTF-8 quad byte char is missing bytes at eof" + + diff --git a/src/Util.hs b/src/Util.hs --- a/src/Util.hs +++ b/src/Util.hs @@ -26,6 +26,7 @@ import Control.Monad.Except import Control.Monad.Identity as X +import Data.Char as X (chr, ord) import Data.Map as X (Map) import Data.Monoid as X (Monoid (mappend, mempty)) import Data.Set as X (Set)