
   0 | module Text.YAML.Types
   1 | 
   2 | import Data.List
   3 | import Derive.Prelude
   4 | import public Text.ParseError
   5 | 
   6 | %default total
   7 | %language ElabReflection
   8 | 
   9 | --------------------------------------------------------------------------------
  10 | --          Events
  11 | --------------------------------------------------------------------------------
  12 | 
  13 | ||| Name given in a node's `&anchor` property or referenced
  14 | ||| by an `*alias` node.
  15 | public export
  16 | 0 Anchor : Type
  17 | Anchor = String
  18 | 
  19 | ||| The presentation style of a scalar node.
  20 | public export
  21 | data Style : Type where
  22 |   ||| An unquoted scalar
  23 |   Plain   : Style
  24 | 
  25 |   ||| A 'single quoted' scalar
  26 |   SingleQ : Style
  27 | 
  28 |   ||| A "double quoted" scalar
  29 |   DoubleQ : Style
  30 | 
  31 |   ||| A literal (`|`) block scalar
  32 |   Literal : Style
  33 | 
  34 |   ||| A folded (`>`) block scalar
  35 |   Folded  : Style
  36 | 
  37 | %runElab derive "Style" [Show,Eq]
  38 | 
  39 | ||| A node's tag property.
  40 | public export
  41 | data Tag : Type where
  42 |   ||| No tag property was given.
  43 |   NoTag    : Tag
  44 | 
  45 |   ||| The `!` non-specific tag.
  46 |   NonSpec  : Tag
  47 | 
  48 |   ||| A resolved tag: shorthands have been expanded via the active
  49 |   ||| `%TAG` handles, verbatim tags (`!<...>`) are taken as given.
  50 |   Verbatim : String -> Tag
  51 | 
  52 | %runElab derive "Tag" [Show,Eq]
  53 | 
  54 | ||| A YAML parse event.
  55 | |||
  56 | ||| A well-formed event stream follows this grammar:
  57 | |||
  58 | ||| ```
  59 | ||| stream   ::= StreamStart document* StreamEnd
  60 | ||| document ::= DocStart node DocEnd
  61 | ||| node     ::= Alias | Scalar
  62 | |||            | SeqStart node* SeqEnd
  63 | |||            | MapStart (node node)* MapEnd
  64 | ||| ```
  65 | public export
  66 | data Event : Type where
  67 |   StreamStart : Event
  68 |   StreamEnd   : Event
  69 |   DocStart    : (explicit : Bool) -> Event
  70 |   DocEnd      : (explicit : Bool) -> Event
  71 |   SeqStart    : (flow : Bool) -> Maybe Anchor -> Tag -> Event
  72 |   SeqEnd      : Event
  73 |   MapStart    : (flow : Bool) -> Maybe Anchor -> Tag -> Event
  74 |   MapEnd      : Event
  75 |   Scalar      : Maybe Anchor -> Tag -> Style -> String -> Event
  76 |   Alias       : Anchor -> Event
  77 | 
  78 | %runElab derive "Event" [Show,Eq]
  79 | 
  80 | --------------------------------------------------------------------------------
  81 | --          Event Printing
  82 | --------------------------------------------------------------------------------
  83 | 
  84 | escape : SnocList Char -> Char -> SnocList Char
  85 | escape sc '\\' = sc :< '\\' :< '\\'
  86 | escape sc '\0' = sc :< '\\' :< '0'
  87 | escape sc '\b' = sc :< '\\' :< 'b'
  88 | escape sc '\n' = sc :< '\\' :< 'n'
  89 | escape sc '\r' = sc :< '\\' :< 'r'
  90 | escape sc '\t' = sc :< '\\' :< 't'
  91 | escape sc c    = sc :< c
  92 | 
  93 | value : String -> String
  94 | value s = pack (foldl escape [<] (unpack s) <>> [])
  95 | 
  96 | flow : String -> Bool -> String
  97 | flow s True  = " " ++ s
  98 | flow _ False = ""
  99 | 
 100 | anchor : Maybe Anchor -> String
 101 | anchor Nothing  = ""
 102 | anchor (Just a) = " &" ++ a
 103 | 
 104 | tag : Tag -> String
 105 | tag NoTag        = ""
 106 | tag NonSpec      = " <!>"
 107 | tag (Verbatim t) = " <" ++ t ++ ">"
 108 | 
 109 | sigil : Style -> Char
 110 | sigil Plain   = ':'
 111 | sigil SingleQ = '\''
 112 | sigil DoubleQ = '"'
 113 | sigil Literal = '|'
 114 | sigil Folded  = '>'
 115 | 
 116 | ||| Prints an event in the format used by the YAML test suite's
 117 | ||| `test.event` files: https://github.com/yaml/yaml-test-suite
 118 | export
 119 | printEvent : Event -> String
 120 | printEvent StreamStart      = "+STR"
 121 | printEvent StreamEnd        = "-STR"
 122 | printEvent (DocStart True)  = "+DOC ---"
 123 | printEvent (DocStart False) = "+DOC"
 124 | printEvent (DocEnd True)    = "-DOC ..."
 125 | printEvent (DocEnd False)   = "-DOC"
 126 | printEvent (SeqStart f a t) = "+SEQ" ++ flow "[]" f ++ anchor a ++ tag t
 127 | printEvent SeqEnd           = "-SEQ"
 128 | printEvent (MapStart f a t) = "+MAP" ++ flow "{}" f ++ anchor a ++ tag t
 129 | printEvent MapEnd           = "-MAP"
 130 | printEvent (Scalar a t s v) =
 131 |   "=VAL" ++ anchor a ++ tag t ++ " " ++ singleton (sigil s) ++ value v
 132 | printEvent (Alias a)        = "=ALI *" ++ a
 133 | 
 134 | --------------------------------------------------------------------------------
 135 | --          Node Properties and Tag Resolution
 136 | --------------------------------------------------------------------------------
 137 | 
 138 | ||| The properties of a node: at most one anchor and one tag
 139 | ||| [spec: c-ns-properties].
 140 | public export
 141 | record Props where
 142 |   constructor MkProps
 143 |   anchor : Maybe Anchor
 144 |   tag    : Tag
 145 | 
 146 | public export
 147 | noProps : Props
 148 | noProps = MkProps Nothing NoTag
 149 | 
 150 | public export
 151 | isNoProps : Props -> Bool
 152 | isNoProps (MkProps Nothing NoTag) = True
 153 | isNoProps _                       = False
 154 | 
 155 | ||| The tag handles declared by `%TAG` directives; `!` and `!!` have
 156 | ||| built-in defaults.
 157 | public export
 158 | record TagEnv where
 159 |   constructor TE
 160 |   handles : List (String, String)
 161 | 
 162 | public export
 163 | defaultEnv : TagEnv
 164 | defaultEnv = TE []
 165 | 
 166 | --------------------------------------------------------------------------------
 167 | --          Errors
 168 | --------------------------------------------------------------------------------
 169 | 
 170 | ||| YAML-specific parse errors, used as the custom part of
 171 | ||| `InnerError` (see `Text.ParseError`).
 172 | public export
 173 | data YErr : Type where
 174 |   TabIndent       : YErr
 175 |   BadIndent       : YErr
 176 |   MultipleAnchors : YErr
 177 |   MultipleTags    : YErr
 178 |   UnknownHandle   : String -> YErr
 179 |   DuplicateHandle : String -> YErr
 180 |   BadVersion      : String -> YErr
 181 |   BadDirective    : String -> YErr
 182 |   TrailingContent : YErr
 183 |   InvalidKey      : YErr
 184 | 
 185 |   -- composer errors
 186 | 
 187 |   ||| An alias referencing an anchor that is not in scope.
 188 |   UndefinedAlias  : Anchor -> YErr
 189 | 
 190 |   ||| An alias referencing an anchor whose node is still being
 191 |   ||| composed, as in `&a [*a]`: such cyclic structures cannot be
 192 |   ||| represented as finite trees.
 193 |   CyclicAlias     : Anchor -> YErr
 194 | 
 195 |   ||| A mapping with two equal keys [spec 3.2.1.3]. Carries the
 196 |   ||| rendered key.
 197 |   DuplicateKey    : String -> YErr
 198 | 
 199 |   ||| The composer met a malformed event sequence. Event streams
 200 |   ||| produced by `parseEvents` never trigger this. Carries the
 201 |   ||| rendered event.
 202 |   UnexpectedEvent : String -> YErr
 203 | 
 204 |   ||| The events ended in the middle of a node or document.
 205 |   UnexpectedEnd   : YErr
 206 | 
 207 | %runElab derive "YErr" [Show,Eq]
 208 | 
 209 | ||| Resolves a tag shorthand against the active handles
 210 | ||| [spec: c-ns-shorthand-tag].
 211 | export
 212 | resolveTag : TagEnv -> (handle, suffix : String) -> Either YErr Tag
 213 | resolveTag env h sfx = case lookup h env.handles of
 214 |   Just pre => Right (Verbatim (pre ++ sfx))
 215 |   Nothing  => case h of
 216 |     "!"  => Right (Verbatim ("!" ++ sfx))
 217 |     "!!" => Right (Verbatim ("tag:yaml.org,2002:" ++ sfx))
 218 |     _    => Left (UnknownHandle h)
 219 | 
 220 | ||| Combines properties given on a preceding line with those attached
 221 | ||| directly to a node: at most one anchor and one tag in total.
 222 | export
 223 | mergeProps : Props -> Props -> Either YErr Props
 224 | mergeProps (MkProps (Just _) _) (MkProps (Just _) _) = Left MultipleAnchors
 225 | mergeProps (MkProps a1 NoTag) (MkProps a2 t)         = Right (MkProps (a1 <|> a2) t)
 226 | mergeProps (MkProps a1 t) (MkProps a2 NoTag)         = Right (MkProps (a1 <|> a2) t)
 227 | mergeProps _ _                                       = Left MultipleTags
 228 | 
 229 | export
 230 | Interpolation YErr where
 231 |   interpolate TabIndent           = "tab character used for indentation"
 232 |   interpolate BadIndent           = "wrong indentation"
 233 |   interpolate MultipleAnchors     = "more than one anchor for the same node"
 234 |   interpolate MultipleTags        = "more than one tag for the same node"
 235 |   interpolate (UnknownHandle h)   = "unknown tag handle: \{h}"
 236 |   interpolate (DuplicateHandle h) = "duplicate tag handle: \{h}"
 237 |   interpolate (BadVersion v)      = "unsupported YAML version: \{v}"
 238 |   interpolate (BadDirective d)    = "invalid directive: \{d}"
 239 |   interpolate TrailingContent     = "content not allowed after document end"
 240 |   interpolate InvalidKey          = "invalid mapping key"
 241 |   interpolate (UndefinedAlias a)  = "undefined alias: *\{a}"
 242 |   interpolate (CyclicAlias a)     = "alias *\{a} refers to its own ancestor"
 243 |   interpolate (DuplicateKey k)    = "duplicate mapping key: \{k}"
 244 |   interpolate (UnexpectedEvent e) = "unexpected event: \{e}"
 245 |   interpolate UnexpectedEnd       = "unexpected end of events"
 246 |