lenses/xml.aug

   1 (* XML lens for Augeas
   2    Author: Francis Giraldeau <francis.giraldeau@usherbrooke.ca>
   3
   4    Reference: http://www.w3.org/TR/2006/REC-xml11-20060816/
   5 *)
   6
   7 module Xml =
   8
   9 autoload xfm
  10
  11 (************************************************************************
  12  *                           Utilities lens
  13  *************************************************************************)
  14
  15 let dels (s:string)   = del s s
  16 let spc               = /[ \t\r\n]+/
  17 let osp               = /[ \t\r\n]*/
  18 let sep_spc           = del /[ \t\r\n]+/ " "
  19 let sep_osp           = del /[ \t\r\n]*/ ""
  20 let sep_eq            = del /[ \t\r\n]*=[ \t\r\n]*/ "="
  21
  22 let nmtoken             = /[a-zA-Z:_][a-zA-Z0-9:_.-]*/
  23 let word                = /[a-zA-Z][a-zA-Z0-9._-]*/
  24 let char                = /.|(\r?\n)/
  25 (* if we hide the quotes, then we can only accept single or double quotes *)
  26 (* otherwise a put ambiguity is raised *)
  27 let sto_dquote          = dels "\"" . store /[^"]*/ . dels "\"" (* " *)
  28 let sto_squote          = dels "'" . store /[^']*/ . dels "'"
  29
  30 let comment             = [ label "#comment" .
  31                             dels "<!--" .
  32                             store /([^-]|-[^-])*/ .
  33                             dels "-->" ]
  34
  35 let pi_target           = nmtoken - /[Xx][Mm][Ll]/
  36 let empty               = Util.empty
  37 let del_end             = del />[\r?\n]?/ ">\n"
  38 let del_end_simple      = dels ">"
  39
  40 (* This is siplified version of processing instruction
  41  * pi has to not start or end with a white space and the string
  42  * must not contain "?>". We restrict too much by not allowing any
  43  * "?" nor ">" in PI
  44  *)
  45 let pi                  = /[^ \r\n\t]|[^ \r\n\t][^?>]*[^ \r\n\t]/
  46
  47 (************************************************************************
  48  *                            Attributes
  49  *************************************************************************)
  50
  51
  52 let decl          = [ label "#decl" . sep_spc .
  53                       store /[^> \t\n\r]|[^> \t\n\r][^>\t\n\r]*[^> \t\n\r]/ ]
  54
  55 let decl_def (r:regexp) (b:lens) = [ dels "<" . key r .
  56                                      sep_spc . store nmtoken .
  57                                      b . sep_osp . del_end_simple ]
  58
  59 let elem_def      = decl_def /!ELEMENT/ decl
  60
  61 let enum          = "(" . osp . nmtoken . ( osp . "|" . osp . nmtoken )* . osp . ")"
  62
  63 let att_type      = /CDATA|ID|IDREF|IDREFS|ENTITY|ENTITIES|NMTOKEN|NMTOKENS/ |
  64                      enum
  65
  66 let id_def        = [ sep_spc . key /PUBLIC/ .
  67                       [ label "#literal" . sep_spc . sto_dquote ]* ] |
  68                     [ sep_spc . key /SYSTEM/ . sep_spc . sto_dquote ]
  69
  70 let notation_def  = decl_def /!NOTATION/ id_def
  71
  72 let att_def       = counter "att_id" .
  73                     [ sep_spc . seq "att_id" .
  74                       [ label "#name" . store word . sep_spc ] .
  75                       [ label "#type" . store att_type . sep_spc ] .
  76                       ([ key   /#REQUIRED|#IMPLIED/ ] |
  77                        [ label "#FIXED" . del /#FIXED[ \r\n\t]*|/ "" . sto_dquote ]) ]*
  78
  79 let att_list_def = decl_def /!ATTLIST/ att_def
  80
  81 let entity_def   =
  82   let literal (lbl:string) = [ sep_spc . label lbl . sto_dquote ] in
  83   decl_def /!ENTITY/
  84     ( literal "#decl"
  85     | [ sep_spc . key /SYSTEM/ . literal "#systemliteral" ]
  86     | [ sep_spc . key /PUBLIC/ . literal "#pubidliteral"
  87                                . literal "#systemliteral" ] )
  88
  89 let decl_def_item = elem_def | entity_def | att_list_def | notation_def
  90
  91 let decl_outer    = sep_osp . del /\[[ \n\t\r]*/ "[\n" .
  92                     (decl_def_item . sep_osp )* . dels "]"
  93
  94 (* let dtd_def       = [ sep_spc . key "SYSTEM" . sep_spc . sto_dquote ] *)
  95
  96 let doctype       = decl_def /!DOCTYPE/ (decl_outer|id_def)
  97
  98 (* General shape of an attribute
  99  * q   is the regexp matching the quote character for the value
 100  * qd  is the default quote character
 101  * brx is what the actual attribute value must match *)
 102 let attval (q:regexp) (qd:string) (brx:regexp) =
 103   let quote = del q qd in
 104   let body = store brx in
 105   [ sep_spc . key nmtoken . sep_eq . square quote body quote ]
 106
 107 (* We treat attributes according to one of the following three patterns:
 108    attval1 : values that must be quoted with single quotes
 109    attval2 : values that must be quoted with double quotes
 110    attval3 : values that can be quoted with either *)
 111 let attributes    =
 112   let attval1 = attval "'" "'" /[^']*"[^']*/ in (* " *)
 113   let attval2 = attval "\"" "\"" /[^"]*'[^"]*/ in
 114   let attval3 = attval /['"]/ "\"" /(\\\\|[^'\"])*/ in (* " *)
 115   [ label "#attribute" . (attval1|attval2|attval3)+ ]
 116
 117 let prolog        = [ label "#declaration" .
 118                       dels "<?xml" .
 119                       attributes .
 120                       sep_osp .
 121                       dels "?>" ]
 122
 123
 124 (************************************************************************
 125  *                            Tags
 126  *************************************************************************)
 127
 128 (* we consider entities as simple text *)
 129 let text_re   = /[^<]+/ - /([^<]*\]\]>[^<]*)/
 130 let text      = [ label "#text" . store text_re ]
 131 let cdata     = [ label "#CDATA" . dels "<![CDATA[" .
 132                   store (char* - (char* . "]]>" . char*)) . dels "]]>" ]
 133
 134 (* the value of nmtoken_del is always the nmtoken_key string *)
 135 let nmtoken_key = key nmtoken
 136 let nmtoken_del = del nmtoken "a"
 137
 138 let element (body:lens) =
 139     let h = attributes? . sep_osp . dels ">" . body* . dels "</" in
 140         [ dels "<" . square nmtoken_key h nmtoken_del . sep_osp . del_end ]
 141
 142 let empty_element = [ dels "<" . nmtoken_key . value "#empty" .
 143                       attributes? . sep_osp . del /\/>[\r?\n]?/ "/>\n" ]
 144
 145 let pi_instruction = [ dels "<?" . label "#pi" .
 146                        [ label "#target" . store pi_target ] .
 147                        [ sep_spc . label "#instruction" . store pi ]? .
 148                        sep_osp . del /\?>/ "?>" ]
 149
 150 (* Typecheck is weaker on rec lens, detected by unfolding *)
 151 (*
 152 let content1 = element text
 153 let rec content2 = element (content1|text|comment)
 154 *)
 155
 156 let rec content = element (text|comment|content|empty_element|pi_instruction|cdata)
 157
 158 (* Constraints are weaker here, but it's better than being too strict *)
 159 let doc = (sep_osp . (prolog  | comment | doctype | pi_instruction))* .
 160           ((sep_osp . content) | (sep_osp . empty_element)) .
 161           (sep_osp . (comment | pi_instruction ))* . sep_osp
 162
 163 let lns = doc | Util.empty?
 164
 165 let filter = (incl "/etc/xml/*.xml")
 166     . (incl "/etc/xml/catalog")
 167
 168 let xfm = transform lns filter