HsYAML 0.1.1.0 → 0.1.1.1

raw patch · 8 files changed

+733/−567 lines, 8 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +13/−1
• HsYAML.cabal +2/−1
• src-test/Main.hs +25/−1
• src/Data/YAML.hs +5/−0
• src/Data/YAML/Event.hs +101/−30
• src/Data/YAML/Token.hs +330/−534
• src/Data/YAML/Token/Encoding.hs +256/−0
• src/Util.hs +1/−0

@@ -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 

@@ -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

@@ -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 "<stdin>:%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

@@ -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)) 

@@ -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+

@@ -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 <?@ matches the current point without consuming any -- characters, if the previous character matches the lookbehind parser (single@@ -746,152 +544,148 @@ -- | @parser - rejected@ matches /parser/, except if /rejected/ matches at this -- point. (-) :: (Match match1 result1, Match match2 result2) => 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 ?) ) ) *)

@@ -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"++

@@ -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)