HsYAML-0.2.1.3: src/Data/YAML/Event.hs
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE Safe #-}
-- |
-- Copyright: © Herbert Valerio Riedel 2015-2018
-- SPDX-License-Identifier: GPL-2.0-or-later
--
-- Event-stream oriented YAML parsing and serializing API
module Data.YAML.Event
(
-- * Tutorial
-- $start
-- ** Parsing YAML Documents
-- $parsing
parseEvents
-- ** Serializing Events to YAML Character Stream
-- $serialize
, writeEvents
, writeEventsText
-- ** How to comment your yaml document for best results
-- $commenting
-- ** Event-stream Internals
, EvStream
, Event(..)
, EvPos(..)
, Directives(..)
, ScalarStyle(..)
, NodeStyle(..)
, Chomp(..)
, IndentOfs(..)
, Tag, untagged, isUntagged, tagToText, mkTag
, Anchor
, Pos(..)
) where
import Data.YAML.Event.Internal
import Data.YAML.Event.Writer (writeEvents, writeEventsText)
import qualified Data.ByteString.Lazy as BS.L
import qualified Data.Char as C
import qualified Data.Map as Map
import qualified Data.Text as T
import qualified Data.YAML.Token as Y
import Numeric (readHex)
import Util
-- | Construct YAML tag
mkTag :: String -> Tag
mkTag "" = error "mkTag"
mkTag "!" = Tag (Just $! T.pack "!")
mkTag s = Tag (Just $! tagUnescape s)
where
tagUnescape = T.pack . go
where
go [] = []
go ('%':h:l:cs)
| Just c <- decodeL1 [h,l] = c : go cs
go (c:cs) = c : go cs
mkTag' :: String -> Tag
mkTag' "" = error "mkTag'"
mkTag' s = Tag (Just $! T.pack s)
mkTag'' :: String -> Tag
mkTag'' "" = error "mkTag''"
mkTag'' s = Tag (Just $! T.pack ("tag:yaml.org,2002:" ++ s))
-- Returns the position corresponding to the 'Token'
tok2pos :: Y.Token -> Pos
tok2pos Y.Token { Y.tByteOffset = posByteOffset, Y.tCharOffset = posCharOffset, Y.tLine = posLine, Y.tLineChar = posColumn } = Pos {..}
-- Construct a 'EvPos' from the given 'Event' and 'Pos'
getEvPos :: Event -> Y.Token -> EvPos
getEvPos ev tok = EvPos { eEvent = ev , ePos = tok2pos tok }
-- Initial position('Pos' corresponding to the 'StreamStart')
initPos :: Pos
initPos = Pos { posByteOffset = 0 , posCharOffset = 0 , posLine = 1 , posColumn = 0 }
-- internal
type TagHandle = Text
type Props = (Maybe Text,Tag)
getHandle :: [Y.Token] -> Maybe (TagHandle,[Y.Token])
getHandle toks0 = do
Y.Token { Y.tCode = Y.BeginHandle } : toks1 <- Just toks0
(hs,Y.Token { Y.tCode = Y.EndHandle } : toks2) <- Just $ span (\Y.Token { Y.tCode = c } -> c `elem` [Y.Indicator,Y.Meta]) toks1
pure (T.pack $ concatMap Y.tText hs, toks2)
getUriTag :: [Y.Token] -> Maybe (Text,[Y.Token])
getUriTag toks0 = do
Y.Token { Y.tCode = Y.BeginTag } : toks1 <- Just toks0
(hs,Y.Token { Y.tCode = Y.EndTag } : toks2) <- Just $ span (\Y.Token { Y.tCode = c } -> c `elem` [Y.Indicator,Y.Meta]) toks1
pure (T.pack $ concatMap Y.tText hs, toks2)
{- WARNING: the code that follows will make you cry; a safety pig is provided below for your benefit.
_
_._ _..._ .-', _.._(`))
'-. ` ' /-._.-' ',/
) \ '.
/ _ _ | \
| a a / |
\ .-. ;
'-('' ).-' ,' ;
'-; | .'
\ \ /
| 7 .__ _.-\ \
| | | ``/ /` /
/,_| | /,_/ /
/,_/ '`-'
-}
fixUpEOS :: EvStream -> EvStream
fixUpEOS = go initPos
where
go :: Pos -> EvStream -> EvStream
go _ [] = []
go p [Right (EvPos StreamEnd _)] = [Right (EvPos StreamEnd p)]
go _ (e@(Right (EvPos _ p)):es) = e : go p es
go _ (e@(Left (p,_)):es) = e : go p es
-- | Parse YAML 'Event's from a lazy 'BS.L.ByteString'.
--
-- The parsed Events allow us to round-trip at the event-level while preserving many features and presentation details like
-- 'Comment's,'ScalarStyle','NodeStyle', 'Anchor's, 'Directives' marker along with YAML document version,
-- 'Chomp'ing Indicator,Indentation Indicator ('IndentOfs') ,ordering, etc.
-- It does not preserve non-content white spaces.
--
-- 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 -> fixUpEOS $ Right (EvPos StreamStart initPos) : (go0 $ filter (not . isWhite) $ Y.tokenize bs0 False)
where
isTCode tc = (== tc) . Y.tCode
skipPast tc (t : ts)
| isTCode tc t = ts
| otherwise = skipPast tc ts
skipPast _ [] = error "the impossible happened"
-- non-content whitespace
isWhite :: Y.Token -> Bool
isWhite (Y.Token { Y.tCode = Y.Bom }) = True -- BOMs can occur at each doc-start!
isWhite (Y.Token { Y.tCode = Y.White }) = True
isWhite (Y.Token { Y.tCode = Y.Indent }) = True
isWhite (Y.Token { Y.tCode = Y.Break }) = True
isWhite _ = False
go0 :: Tok2EvStream
go0 [] = [Right (EvPos StreamEnd initPos {- fixed up by fixUpEOS -} )]
go0 toks0@(Y.Token { Y.tCode = Y.BeginComment} : _) = goComment toks0 go0
go0 toks0@(Y.Token { Y.tCode = Y.BeginDocument } : _) = go1 dinfo0 toks0
go0 (Y.Token { Y.tCode = Y.DocumentEnd } : rest) = go0 rest -- stray/redundant document-end markers cause this
go0 xs = err xs
go1 :: DInfo -> Tok2EvStream
go1 m (Y.Token { Y.tCode = Y.BeginDocument } : rest) = goDirs m rest
go1 _ (tok@Y.Token { Y.tCode = Y.EndDocument } : Y.Token { Y.tCode = Y.DocumentEnd } : rest) = ( Right (getEvPos (DocumentEnd True) tok )): go0 rest
go1 _ (tok@Y.Token { Y.tCode = Y.EndDocument } : rest) = ( Right (getEvPos (DocumentEnd False) tok )) : go0 rest
go1 m toks0@(Y.Token { Y.tCode = Y.BeginComment} : _) = goComment toks0 (go1 m)
go1 m (Y.Token { Y.tCode = Y.BeginNode } : rest) = goNode0 m rest (go1 m)
go1 _ xs = err xs
-- consume {Begin,End}Directives and emit DocumentStart event
goDirs :: DInfo -> Tok2EvStream
goDirs m (Y.Token { Y.tCode = Y.BeginDirective } : rest) =
goDir1 m rest
goDirs m toks0@(Y.Token { Y.tCode = Y.BeginComment} : _) =
goComment toks0 (goDirs m)
goDirs m (tok@Y.Token { Y.tCode = Y.DirectivesEnd } : rest)
| Just (1,mi) <- diVer m = Right (getEvPos (DocumentStart (DirEndMarkerVersion mi)) tok) : go1 m rest
| otherwise = Right (getEvPos (DocumentStart DirEndMarkerNoVersion) tok) : go1 m rest
goDirs _ xs@(Y.Token { Y.tCode = Y.BeginDocument } : _) =
err xs
goDirs m xs@(tok : _) =
Right (getEvPos (DocumentStart NoDirEndMarker) tok) : go1 m xs
goDirs _ xs =
err xs
-- single directive
goDir1 :: DInfo -> [Y.Token] -> EvStream
goDir1 m toks0@(Y.Token { Y.tCode = Y.Indicator, Y.tText = "%" } :
Y.Token { Y.tCode = Y.Meta, Y.tText = "YAML" } :
Y.Token { Y.tCode = Y.Meta, Y.tText = v } :
Y.Token { Y.tCode = Y.EndDirective } :
rest)
| diVer m /= Nothing = errMsg "Multiple %YAML directives" toks0
| Just (1,mi) <- decodeVer v = goDirs (m { diVer = Just (1,mi) }) rest -- TODO: warn for non-1.2
| otherwise = errMsg ("Unsupported YAML version " <> show v) toks0
goDir1 m toks0@(Y.Token { Y.tCode = Y.Indicator, Y.tText = "%" } :
Y.Token { Y.tCode = Y.Meta, Y.tText = "TAG" } :
rest)
| Just (h, rest') <- getHandle rest
, Just (t, rest'') <- getUriTag rest' = case mapInsertNoDupe h t (diTags m) of
Just tm -> goDirs (m { diTags = tm }) (skipPast Y.EndDirective rest'')
Nothing -> errMsg ("Multiple %TAG definitions for handle " <> show h) toks0
goDir1 m (Y.Token { Y.tCode = Y.Indicator, Y.tText = "%" } :
Y.Token { Y.tCode = Y.Meta, Y.tText = l } :
rest) | l `notElem` ["TAG","YAML"] = goDirs m (skipPast Y.EndDirective rest)
goDir1 _ xs = err xs
-- | Decode versions of the form @<major>.<minor>@
decodeVer :: String -> Maybe (Word,Word)
decodeVer s = do
(lhs,'.':rhs) <- Just (break (=='.') s)
(,) <$> readMaybe lhs <*> readMaybe rhs
data DInfo = DInfo { diTags :: Map.Map TagHandle Text
, diVer :: Maybe (Word,Word)
}
dinfo0 :: DInfo
dinfo0 = DInfo mempty Nothing
errMsg :: String -> Tok2EvStream
errMsg msg (tok : _) = [Left (tok2pos tok, msg)]
errMsg msg [] = [Left ((Pos (-1) (-1) (-1) (-1)), ("Unexpected end of token stream: " <> msg))]
err :: Tok2EvStream
err (tok@Y.Token { Y.tCode = Y.Error, Y.tText = msg } : _) = [Left (tok2pos tok, msg)]
err (tok@Y.Token { Y.tCode = Y.Unparsed, Y.tText = txt } : _) = [Left (tok2pos tok, ("Lexical error near " ++ show txt))]
err (tok@Y.Token { Y.tCode = code } : _) = [Left (tok2pos tok, ("Parse failure near " ++ show code ++ " token"))]
err [] = [Left ((Pos (-1) (-1) (-1) (-1)), "Unexpected end of token stream")]
goNode0 :: DInfo -> Tok2EvStreamCont
goNode0 DInfo {..} = goNode
where
seqInd "[" = Flow
seqInd "-" = Block
seqInd _ = error "seqInd: internal error" -- impossible
mapInd "{" = Flow
mapInd _ = error "mapInd: internal error" -- impossible
goNode :: Tok2EvStreamCont
goNode toks0@(Y.Token { Y.tCode = Y.BeginComment} : _) cont = goComment toks0 (flip goNode cont)
goNode (tok@Y.Token { Y.tCode = Y.BeginScalar } : rest) cont = goScalar (tok2pos tok) (mempty,untagged) rest (flip goNodeEnd cont)
goNode (tok@Y.Token { Y.tCode = Y.BeginSequence } : Y.Token { Y.tCode = Y.Indicator, Y.tText = ind } : rest) cont = Right (getEvPos (SequenceStart Nothing untagged (seqInd ind)) tok): goSeq rest (flip goNodeEnd cont)
goNode (tok@Y.Token { Y.tCode = Y.BeginMapping } : Y.Token { Y.tCode = Y.Indicator, Y.tText = ind } : rest) cont = Right (getEvPos (MappingStart Nothing untagged (mapInd ind)) tok) : goMap rest (flip goNodeEnd cont)
goNode (tok@Y.Token { Y.tCode = Y.BeginMapping } : rest) cont = Right (getEvPos (MappingStart Nothing untagged Block) tok) : goMap rest (flip goNodeEnd cont)
goNode (Y.Token { Y.tCode = Y.BeginProperties } : rest) cont = goProp (mempty,untagged) rest (\p rest' -> goNode' p rest' cont)
goNode (tok@Y.Token { Y.tCode = Y.BeginAlias } :
Y.Token { Y.tCode = Y.Indicator } :
Y.Token { Y.tCode = Y.Meta, Y.tText = anchor } :
Y.Token { Y.tCode = Y.EndAlias } :
Y.Token { Y.tCode = Y.EndNode } :
rest) cont = Right (getEvPos (Alias (T.pack anchor)) tok) : cont rest
goNode xs _cont = err xs
goNode' :: Props -> Tok2EvStreamCont
goNode' props toks0@(Y.Token { Y.tCode = Y.BeginComment} : _) cont = goComment toks0 (flip (goNode' props) cont)
goNode' props (tok@Y.Token { Y.tCode = Y.BeginScalar } : rest) cont = goScalar (tok2pos tok) props rest (flip goNodeEnd cont)
goNode' (manchor,mtag) (tok@Y.Token { Y.tCode = Y.BeginSequence } : Y.Token { Y.tCode = Y.Indicator, Y.tText = ind } : rest) cont = Right (getEvPos (SequenceStart manchor mtag (seqInd ind)) tok) : goSeq rest (flip goNodeEnd cont)
goNode' (manchor,mtag) (tok@Y.Token { Y.tCode = Y.BeginMapping } : Y.Token { Y.tCode = Y.Indicator, Y.tText = ind } : rest) cont = Right (getEvPos (MappingStart manchor mtag (mapInd ind)) tok) : goMap rest (flip goNodeEnd cont)
goNode' (manchor,mtag) (tok@Y.Token { Y.tCode = Y.BeginMapping } : rest) cont = Right (getEvPos (MappingStart manchor mtag Block) tok) : goMap rest (flip goNodeEnd cont)
goNode' _ xs _cont = err xs
goNodeEnd :: Tok2EvStreamCont
goNodeEnd toks0@(Y.Token { Y.tCode = Y.BeginComment} : _) cont = goComment toks0 (flip goNodeEnd cont)
goNodeEnd (Y.Token { Y.tCode = Y.EndNode } : rest) cont = cont rest
goNodeEnd xs _cont = err xs
goProp :: Props -> [Y.Token] -> (Props -> [Y.Token] -> EvStream) -> EvStream
goProp props (Y.Token { Y.tCode = Y.EndProperties } : rest) cont = cont props rest
goProp props (Y.Token { Y.tCode = Y.BeginAnchor } : rest) cont = goAnchor props rest (\x y -> goProp x y cont)
goProp props (Y.Token { Y.tCode = Y.BeginTag } : rest) cont = goTag props rest (\x y -> goProp x y cont)
goProp _props xs _cont = err xs
goAnchor :: Props -> [Y.Token] -> (Props -> [Y.Token] -> EvStream) -> EvStream
goAnchor props (Y.Token { Y.tCode = Y.Indicator } : rest) cont = goAnchor props rest cont
goAnchor (_,tag) (Y.Token { Y.tCode = Y.Meta, Y.tText = anchor } : rest) cont = goAnchor (Just $! T.pack anchor,tag) rest cont
goAnchor props (Y.Token { Y.tCode = Y.EndAnchor } : rest) cont = cont props rest
goAnchor _ xs _ = err xs
goTag :: Props -> [Y.Token] -> (Props -> [Y.Token] -> EvStream) -> EvStream
goTag (anchor,_) (Y.Token { Y.tCode = Y.Indicator, Y.tText = "!" } :
Y.Token { Y.tCode = Y.EndTag } : rest)
cont = cont (anchor,mkTag' "!") rest
goTag (anchor,_) (Y.Token { Y.tCode = Y.BeginHandle } :
Y.Token { Y.tCode = Y.Indicator, Y.tText = "!" } :
Y.Token { Y.tCode = Y.Indicator, Y.tText = "!" } :
Y.Token { Y.tCode = Y.EndHandle } :
Y.Token { Y.tCode = Y.Meta, Y.tText = tag } :
Y.Token { Y.tCode = Y.EndTag } : rest)
cont
| Just t' <- Map.lookup (T.pack ("!!")) diTags
= cont (anchor,mkTag (T.unpack t' ++ tag)) rest
| otherwise = cont (anchor,mkTag'' tag) rest
goTag (anchor,_) (Y.Token { Y.tCode = Y.Indicator, Y.tText = "!" } :
Y.Token { Y.tCode = Y.Indicator, Y.tText = "<" } :
Y.Token { Y.tCode = Y.Meta, Y.tText = tag } :
Y.Token { Y.tCode = Y.Indicator, Y.tText = ">" } :
Y.Token { Y.tCode = Y.EndTag } : rest)
cont = cont (anchor,mkTag tag) rest
goTag (anchor,_) xs@(Y.Token { Y.tCode = Y.BeginHandle } :
Y.Token { Y.tCode = Y.Indicator, Y.tText = "!" } :
Y.Token { Y.tCode = Y.Meta, Y.tText = h } :
Y.Token { Y.tCode = Y.Indicator, Y.tText = "!" } :
Y.Token { Y.tCode = Y.EndHandle } :
Y.Token { Y.tCode = Y.Meta, Y.tText = tag } :
Y.Token { Y.tCode = Y.EndTag } : rest)
cont
| Just t' <- Map.lookup (T.pack ("!" ++ h ++ "!")) diTags
= cont (anchor,mkTag (T.unpack t' ++ tag)) rest
| otherwise = err xs
goTag (anchor,_) (Y.Token { Y.tCode = Y.BeginHandle } :
Y.Token { Y.tCode = Y.Indicator, Y.tText = "!" } :
Y.Token { Y.tCode = Y.EndHandle } :
Y.Token { Y.tCode = Y.Meta, Y.tText = tag } :
Y.Token { Y.tCode = Y.EndTag } : rest)
cont
| Just t' <- Map.lookup (T.pack ("!")) diTags
= cont (anchor,mkTag (T.unpack t' ++ tag)) rest
| otherwise = cont (anchor,mkTag' ('!' : tag)) rest -- unresolved
goTag _ xs _ = err xs
goScalar :: Pos -> Props -> Tok2EvStreamCont
goScalar pos0 (manchor,tag) toks0 cont = go0 False Plain toks0
where
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 Clip IndentAuto) rest
| ">" <- ind = go0 True (Folded Clip IndentAuto) rest
| "+" <- ind = go0 ii (chn sty Keep) rest
| "-" <- ind = go0 ii (chn sty Strip) rest
| [c] <- ind, '1' <= c, c <= '9' = go0 False (chn' sty (C.digitToInt c)) rest
go0 ii sty tok@(Y.Token { Y.tCode = Y.BeginComment} : _) = goComment tok (go0 ii sty)
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 (EvPos (Scalar manchor tag sty mempty) pos0) : cont rest
go0 _ _ xs = err xs
chn :: ScalarStyle -> Chomp -> ScalarStyle
chn (Literal _ digit) chmp = Literal chmp digit
chn (Folded _ digit) chmp = Folded chmp digit
chn _ _ = error "impossible"
chn' :: ScalarStyle -> Int -> ScalarStyle
chn' (Literal b _) digit = Literal b (toEnum digit)
chn' (Folded b _) digit = Folded b (toEnum digit)
chn' _ _ = error "impossible"
----------------------------------------------------------------------------
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' ii (acc ++ "'") sty rest
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' ii acc sty rest -- line continuation escape
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)
| Just t' <- unescape t = go' ii (acc ++ t') 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.Indicator, Y.tText = pfx } :
Y.Token { Y.tCode = Y.Meta, Y.tText = ucode } :
Y.Token { Y.tCode = Y.EndEscape } :
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' 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: " ++ show acc)]
| otherwise = Right (EvPos (Scalar manchor tag sty (T.pack acc)) pos0) : cont rest
go' _ _ _ xs = err xs
hasLeadingSpace (' ':_) = True
hasLeadingSpace ('\n':cs) = hasLeadingSpace cs
hasLeadingSpace _ = False
goSeq :: Tok2EvStreamCont
goSeq (tok@Y.Token { Y.tCode = Y.EndSequence } : rest) cont = Right (getEvPos SequenceEnd tok): cont rest
goSeq toks0@(Y.Token { Y.tCode = Y.BeginComment} : _) cont = goComment toks0 (flip goSeq cont)
goSeq (Y.Token { Y.tCode = Y.BeginNode } : rest) cont = goNode rest (flip goSeq cont)
goSeq (tok@Y.Token { Y.tCode = Y.BeginMapping } : Y.Token { Y.tCode = Y.Indicator, Y.tText = ind } : rest) cont = Right (getEvPos (MappingStart Nothing untagged (mapInd ind)) tok) : goMap rest (flip goSeq cont)
goSeq (tok@Y.Token { Y.tCode = Y.BeginMapping } : rest) cont = Right (getEvPos (MappingStart Nothing untagged Block) tok) : goMap rest (flip goSeq cont)
goSeq (Y.Token { Y.tCode = Y.Indicator } : rest) cont = goSeq rest cont
-- goSeq xs _cont = error (show xs)
goSeq xs _cont = err xs
goMap :: Tok2EvStreamCont
goMap (tok@Y.Token { Y.tCode = Y.EndMapping } : rest) cont = Right (getEvPos MappingEnd tok) : cont rest
goMap toks0@(Y.Token { Y.tCode = Y.BeginComment} : _) cont = goComment toks0 (flip goMap cont)
goMap (Y.Token { Y.tCode = Y.BeginPair } : rest) cont = goPair1 rest (flip goMap cont)
goMap (Y.Token { Y.tCode = Y.Indicator } : rest) cont = goMap rest cont
goMap xs _cont = err xs
goPair1 (Y.Token { Y.tCode = Y.BeginNode } : rest) cont = goNode rest (flip goPair2 cont)
goPair1 toks0@(Y.Token { Y.tCode = Y.BeginComment} : _) cont = goComment toks0 (flip goPair1 cont)
goPair1 (Y.Token { Y.tCode = Y.Indicator } : rest) cont = goPair1 rest cont
goPair1 xs _cont = err xs
goPair2 toks0@(Y.Token { Y.tCode = Y.BeginComment} : _) cont = goComment toks0 (flip goPair2 cont)
goPair2 (Y.Token { Y.tCode = Y.BeginNode } : rest) cont = goNode rest (flip goPairEnd cont)
goPair2 (Y.Token { Y.tCode = Y.Indicator } : rest) cont = goPair2 rest cont
goPair2 xs _cont = err xs
goPairEnd toks0@(Y.Token { Y.tCode = Y.BeginComment} : _) cont = goComment toks0 (flip goPairEnd cont)
goPairEnd (Y.Token { Y.tCode = Y.EndPair } : rest) cont = cont rest
goPairEnd xs _cont = err xs
goComment :: Tok2EvStreamCont
goComment (tok@Y.Token { Y.tCode = Y.BeginComment} :
Y.Token { Y.tCode = Y.Indicator, Y.tText = "#" } :
Y.Token { Y.tCode = Y.Meta, Y.tText = comment } :
Y.Token { Y.tCode = Y.EndComment } : rest) cont = (Right (getEvPos (Comment (T.pack comment)) tok)) : cont rest
goComment (tok@Y.Token { Y.tCode = Y.BeginComment} :
Y.Token { Y.tCode = Y.Indicator, Y.tText = "#" } :
Y.Token { Y.tCode = Y.EndComment } : rest) cont = (Right (getEvPos (Comment T.empty) tok)) : cont rest
goComment xs _cont = err xs
-- stripComments :: [Y.Token] -> [Y.Token]
-- stripComments (Y.Token { Y.tCode = Y.BeginComment } : rest) = skip rest
-- where
-- skip (Y.Token { Y.tCode = Y.EndComment } : rest') = stripComments rest'
-- skip (_ : rest') = skip rest'
-- skip [] = error "the impossible happened"
-- stripComments (t : rest) = t : stripComments rest
-- stripComments [] = []
type Tok2EvStream = [Y.Token] -> EvStream
type Tok2EvStreamCont = [Y.Token] -> Cont EvStream [Y.Token]
type Cont r a = (a -> r) -> r
-- decode 8-hex-digit unicode code-point
decodeCP2 :: String -> Maybe Char
decodeCP2 s = case s of
[_,_,_,_,_,_,_,_] | all C.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
[_,_,_,_] | all C.isHexDigit s
, [(j, "")] <- readHex s -> Just (chr (fromInteger j))
_ -> Nothing
-- decode 2-hex-digit latin1 code-point
decodeL1 :: String -> Maybe Char
decodeL1 s = case s of
[_,_] | all C.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
--
-- $start
--
-- "Data.YAML" module provides us with API which allow us to interact with YAML data at the cost of some presentation details.
-- In contrast, this module provide us with API which gives us access to a other significant details like 'ScalarStyle's, 'NodeStyle's, 'Comment's, etc.
--
-- $parsing
--
-- Suppose you want to parse this YAML Document while preserving its format and comments
--
-- @
-- # Home runs
-- hr: 65
-- # Runs Batted In
-- rbi: 147
-- @
--
-- then you might want to use the function 'parseEvents'.
--
-- The following is a reference implementation of a function using 'parseEvents'.
-- It takes a YAML document as input and prints the parsed YAML 'Event's.
--
-- @
-- import Data.YAML.Event
-- import qualified Data.ByteString.Lazy as BS.L
--
-- printEvents :: BS.L.ByteString -> IO ()
-- printEvents input =
-- forM_ ('parseEvents' input) $ \ev -> case ev of
-- Left _ -> error "Failed to parse"
-- Right event -> print ('eEvent' event)
-- @
--
-- When we pass the above mentioned YAML document to the function /printEvents/ it outputs the following:
--
-- > StreamStart
-- > DocumentStart NoDirEndMarker
-- > MappingStart Nothing Nothing Block
-- > Comment " Home runs"
-- > Scalar Nothing Nothing Plain "hr"
-- > Scalar Nothing Nothing Plain "65"
-- > Comment " Runs Batted In"
-- > Scalar Nothing Nothing Plain "rbi"
-- > Scalar Nothing Nothing Plain "147"
-- > MappingEnd
-- > DocumentEnd False
-- > StreamEnd
--
-- Notice that now we have all the necessary details in the form of 'Event's.
--
-- We can now write simple functions to work with this data without losing any more details.
--
-- $serialize
--
-- Now, suppose we want to generate back the YAML document after playing with the Event-stream,
-- then you might want to use 'writeEvents'.
--
-- The following function takes a YAML document as a input and dumps it back to STDOUT after a round-trip.
--
-- @
-- import Data.YAML.Event
-- import qualified Data.YAML.Token as YT
-- import qualified Data.ByteString.Lazy as BS.L
--
-- yaml2yaml :: BS.L.ByteString -> IO ()
-- yaml2yaml input = case sequence $ parseEvents input of
-- Left _ -> error "Parsing Failure!"
-- Right events -> do
-- BS.L.hPutStr stdout (writeEvents YT.UTF8 (map eEvent events))
-- hFlush stdout
-- @
--
-- Let this be the sample document passed to the above function
--
-- @
-- # This is a 'Directives' Marker
-- ---
-- # All 'Comment's are preserved
-- date : 2019-07-12
-- bill-to : # 'Anchor' represents a map node
-- &id001
-- address:
-- lines: # This a Block 'Scalar' with 'Keep' chomping Indicator and 'IndentAuto' Indentant indicator
-- |+ # Extra Indentation (non-content white space) will not be preserved
-- Vijay
-- IIT Hyderabad
--
--
-- # Trailing newlines are a preserved here as they are a part of the 'Scalar' node
-- country : India
-- ship-to : # This is an 'Alias'
-- *id001
-- # Key is a 'Scalar' and Value is a Sequence
-- Other Details:
-- total: $ 3000
-- # 'Tag's are also preserved
-- Online Payment: !!bool True
-- product:
-- - Item1
-- # This comment is inside a Sequence
-- - Item2
-- ...
-- # 'DocumentEnd' True
-- # 'StreamEnd'
-- @
--
-- This function outputs the following
--
-- @
-- # This is a 'Directives' Marker
-- ---
-- # All 'Comment's are preserved
-- date: 2019-07-12
-- bill-to: # 'Anchor' represents a map node
-- &id001
-- address:
-- lines: # This a Block 'Scalar' with 'Keep' chomping Indicator and 'IndentAuto' Indentant indicator
-- # Extra Indentation (non-content white space) will not be preserved
-- |+
-- Vijay
-- IIT Hyderabad
--
--
-- # Trailing newlines are a preserved here as they are a part of the 'Scalar' node
-- country: India
-- ship-to: # This is an 'Alias'
-- *id001
-- # Key is a 'Scalar' and Value is a Sequence
-- Other Details:
-- total: $ 3000
-- # 'Tag's are also preserved
-- Online Payment: !!bool True
-- product:
-- - Item1
-- # This comment is inside a Sequence
-- - Item2
-- ...
-- # 'DocumentEnd' True
-- # 'StreamEnd'
-- @
--
-- $commenting
--
-- Round-tripping at event-level will preserve all the comments and their relative position in the YAML-document but still,
-- we lose some information like the exact indentation and the position at which the comments were present previously.
-- This information sometimes can be quite important for human-perception of comments.
-- Below are some guildlines, so that you can avoid ambiguities.
--
-- 1) Always try to start your comment in a newline. This step will avoid most of the ambiguities.
--
-- 2) Comments automaticly get indented according to the level in which they are present. For example,
--
-- Input YAML-document
--
-- @
-- # Level 0
-- - a
-- # Level 0
-- - - a
-- # Level 1
-- - a
-- - - a
-- # Level 2
-- - a
-- @
--
-- After a round-trip looks like
--
-- @
-- # Level 0
-- - a
-- # Level 0
-- - - a
-- # Level 1
-- - a
-- - - a
-- # Level 2
-- - a
-- @
--
-- 3) Comments immediately after a 'Scalar' node, start from a newline. So avoid commenting just after a scalar ends, as it may lead to some ambiguity. For example,
--
-- Input YAML-document
--
-- @
-- - scalar # After scalar
-- - random : scalar # After scalar
-- key: 1
-- # not after scalar
-- - random : scalar
-- key: 1
-- - random : # not after scalar
-- scalar
-- # not after scalar
-- key: 1
-- @
--
-- After a round-trip looks like
--
-- @
-- - scalar
-- # After scalar
-- - random: scalar
-- # After scalar
-- key: 1
-- # not after scalar
-- - random: scalar
-- key: 1
-- - random: # not after scalar
-- scalar
-- # not after scalar
-- key: 1
-- @
--
-- 4) Similarly in flow-style, avoid commenting immediately after a /comma/ (@,@) seperator. Comments immediately after a /comma/ (@,@) seperator will start from a new line
--
-- Input YAML-document
--
-- @
-- {
-- # comment 0
-- Name: Vijay # comment 1
-- ,
-- # comment 2
-- age: 19, # comment 3
-- # comment 4
-- country: India # comment 5
-- }
-- @
--
-- After a round-trip looks like
--
-- @
-- {
-- # comment 0
-- Name: Vijay,
-- # comment 1
-- # comment 2
-- age: 19,
-- # comment 3
-- # comment 4
-- country: India,
-- # comment 5
-- }
-- @
--
-- 5) Avoid commenting in between syntatical elements. For example,
--
-- Input YAML-document
--
-- @
-- ? # Complex key starts
-- [
-- a,
-- b
-- ]
-- # Complex key ends
-- : # Complex Value starts
-- ? # Complex key starts
-- [
-- a,
-- b
-- ]
-- # Complex key ends
-- : # Simple value
-- a
-- # Complex value ends
-- @
--
-- After a round-trip looks like
--
-- @
-- ? # Complex key starts
-- [
-- a,
-- b
-- ]
-- : # Complex key ends
-- # Complex Value starts
--
-- ? # Complex key starts
-- [
-- a,
-- b
-- ]
-- : # Complex key ends
-- # Simple value
-- a
-- # Complex value ends
-- @
--
-- The above two YAML-documents, after parsing produce the same 'Event'-stream.
--
-- So, these are some limitation of this Format-preserving YAML processor.