HXQ-0.10.0: src/hxml-0.2/XMLScanner.hs
----------------------------------------------------------------------------
--
-- Module : XMLScanner
-- Copyright : (C) 2000-2002 Joe English. Freely redistributable.
-- License : "MIT-style"
--
-- Author : Joe English <jenglish@flightlab.com>
-- Stability : experimental
-- Portability : portable
--
-- CVS : $Id: XMLScanner.hs,v 1.9 2002/10/12 01:58:59 joe Exp $
--
----------------------------------------------------------------------------
--
-- 9 Jan 2000
--
-- doesn't check as many errors as it ought to...
module XMLScanner
( Delimiter(..)
, pcdataMode, markupMode
, isNMCHAR, isSEPCHAR
, expandReferences
) where
import XML -- for "Name"
import Char
import qualified DTD
isSEPCHAR, isNMCHAR, isNMSTART :: Char -> Bool
isSEPCHAR = isSpace
isNMCHAR c = isAlphaNum c || c `elem` ".-_:" -- 2.3 prodn 4
--isNMSTART c = isAlpha c || c `elem` "_:" -- 2.3 prodn 5
isNMSTART c = isAlphaNum c || c `elem` "_:" -- for NUTOKEN, NMTOKEN attvals
-- Utility:
--
-- doSpan pred k f g s = k (f x) (g y) where (x,y) = span pred s
--
doSpan :: (a -> Bool) -> (b -> c -> d) -> ([a] -> b) -> ([a] -> c) -> [a] -> d
doSpan pred k f g = sp f where
sp f' [] = k (f' []) (g [])
sp f' s@(c:cs)
| pred c = sp (f' . (c:)) cs
| otherwise = k (f' []) (g s)
drop1 :: [a] -> [a] -- drop1 == drop 1; safe version of tail
drop1 [] = []
drop1 (_:xs) = xs
data Delimiter =
-- character data mode:
WS String -- whitespace
| CDATA String -- character data
| GEREF Name -- general entity reference
| STAGO -- start tag open, "<"
| ETAGO -- end tag open, "</"
-- Markup mode and character data mode:
| MDO -- markup declaration open, "<!"
| MDOCOM -- MDO + COM delimiter-in-context, "<!--"
| MDODSO -- MDO + DSO delimiter-in-context, "<!["
| PIO -- processing instruction open, "<?"
| PIC -- processing instruction close, "?>" (">" in SGML)
-- Errors:
| LEXERR String -- lexical error
| REST String -- rest of input
-- Markup mode:
| NAME Name -- name
| RNINAME Name -- name prefixed with RNI (#)
| PEREF Name -- parameter entity reference
| LITERAL String -- attribute value literal or parameter literal
| TAGC -- tag close, ">"
| VI -- value indicator, "="
| EETAGC -- empty element tag close (XML), "/>"
| MDC -- markup declaration close, ">"
| DSO -- declaration subset open, "["
| DSC -- declaration subset close, "]"
| MSC -- DSC+MDC, delimiter-in-context, "]]>"
| COM -- comment, "--"
| GRPO -- group open, "("
| GRPC -- group close, ")"
| AND -- and connector, "&"
| OR -- or connector, "|"
| SEQ -- seq connector, ","
| OPT -- opt occurrence indicator, "?"
| REP -- rep occurrence indicator, "*"
| PLUS -- plus occurrence indicator, inclusion, "+"
| MINUS -- exclusion, omission flag, "-"
| PERO -- parameter entity reference open, "%"
-- ALSO:
-- Shortref -- short reference string (SGML only)
-- NET -- null end-tag (SGML only)
-- RNI -- reserved name indicator, "#"
-- LIT -- literal, """
-- LITA -- alternative literal, "'"
-- CRO -- character reference open, "&#"
-- HCRO -- hex character reference open, "&#X" (new in XML)
-- ERO -- entity reference open, "&"
-- REFC -- reference close, ";"
deriving (Eq, Show)
pcdataMode, tagMode, markupMode :: String -> [Delimiter]
-- [STAGO, ETAGO, NET, CRO, ERO, MDO, MDOCOM, MDODSO, PIO, MSC]
pcdataMode [] = []
pcdataMode ('<':s) = case s of
'!':'-':'-':r -> MDOCOM : comMode pcdataMode r
'!':'[':r -> {- MDODSO : -} msMode r
'!':r -> MDO : markupMode r
'/':r -> ETAGO : tagMode r
'?':r -> PIO : piMode pcdataMode r
']':']':'>':r -> MSC : pcdataMode r
r -> STAGO : tagMode r
pcdataMode ('&':'#':s) = doSpan (';'/=) (:) mkCREF (pcdataMode . drop1) s
where mkCREF = CDATA . return . chr . stringToInt 10
pcdataMode ('&':s) =
case span isNMCHAR s of
(ename,';':r) -> GEREF ename : pcdataMode r
(junk,r) -> LEXERR ("Bad entity reference " ++ junk)
: pcdataMode r
pcdataMode ('>':r) = LEXERR "Warning: %%% SKIPPING UNESCAPED '>'":pcdataMode r
pcdataMode (c:s)
| isSEPCHAR c = doSpan isSEPCHAR (:) (WS . (c:)) pcdataMode s
| otherwise = doSpan isDATACHAR (:) (CDATA . (c:)) pcdataMode s
where isDATACHAR ch =
case ch of '<' -> False; '&' ->False; _ -> True
tagMode [] = []
tagMode ('/':'>':r) = EETAGC : pcdataMode r
tagMode ('>':r) = TAGC : pcdataMode r
tagMode ('=':r) = VI : tagMode r
tagMode ('"':r) = doSpan ('"'/=) (:) LITERAL (tagMode . drop1) r
tagMode ('\'':r) = doSpan ('\''/=) (:) LITERAL (tagMode . drop1) r
tagMode ('<':'/':r) = ETAGO : tagMode r -- not allowed in XML
tagMode ('<':r) = STAGO : tagMode r -- not allowed in XML
tagMode cs@(c:s)
| isSEPCHAR c = tagMode (dropWhile isSEPCHAR s)
| isNMSTART c = doSpan isNMCHAR (:) NAME tagMode cs
| otherwise = LEXERR [c] : tagMode s
-- [ERO, CRO, HCRO]
expandReferences :: DTD.EntityMap -> String -> String
expandReferences entities = expand where
expand s = case s of
[] -> []
'&':'#':'X':r -> doCharRef 16 expand r
'&':'#':r -> doCharRef 10 expand r
'&':r -> doEntityRef entities expand r
x:r -> x : expand r
doCharRef :: Int -> (String -> String) -> [Char] -> [Char]
doCharRef base k = doSpan (';'/=) (:) (chr . stringToInt base) (k . drop1)
stringToInt :: Int -> String -> Int
stringToInt base = foldl digit 0 . map (\x -> if isDigit x then digitToInt x else 0)
where digit num next = base*num + next
-- @@@ This is not quite right: should rescan the replacement text.
doEntityRef :: DTD.EntityMap -> (String -> String) -> String -> String
doEntityRef entities k r = doSpan (';'/=) (++) replacement (k . drop1) r where
replacement ename = case DTD.expandInternalEntity entities ename of
Just s -> s
-- changed by Leonidas Fegaras 5/27/08
_ -> "" -- error ("entity " ++ ename ++ " not defined")
-- [...]
markupMode [] = []
markupMode ('%':s) = case span isNMCHAR s of
([], ' ':r) -> PERO : markupMode r -- %%% Not Quite Right
(ename,';':r) -> PEREF ename : markupMode r
(ename,r) -> LEXERR ("Bad parameter entity reference %" ++ ename)
: markupMode r
markupMode ('-':'-':r) = eatComment r
markupMode ('>':r) = MDC : markupMode r -- %%% or pcdataMode?
markupMode ('"':r) = doSpan ('"'/=) (:) LITERAL (markupMode . drop1) r
markupMode ('\'':r) = doSpan ('\''/=) (:) LITERAL (markupMode . drop1) r
markupMode ('#':r) = doSpan isNMCHAR (:) (RNINAME . ('#':)) markupMode r
markupMode ('<':'!':'-':'-':r)
= MDOCOM : comMode markupMode r
markupMode ('<':'!':r) = MDO : markupMode r
markupMode ('<':'?':r) = PIO : piMode markupMode r
markupMode s@('<':_) = pcdataMode s -- %%% Not strictly correct, but
-- %%% needed to parse the prolog.
markupMode cs@(c:s)
| isSEPCHAR c = markupMode (dropWhile isSEPCHAR s)
| isNMSTART c = doSpan isNMCHAR (:) NAME markupMode cs
| otherwise = (case c of
'&' -> AND
'|' -> OR
',' -> SEQ
'?' -> OPT
'*' -> REP
'+' -> PLUS
'-' -> MINUS
'[' -> DSO
']' -> DSC
'(' -> GRPO
')' -> GRPC
_ -> LEXERR [c]) : markupMode s
--
-- Internal recognition modes:
--
msMode, cdataMode, eatComment :: String -> [Delimiter]
piMode, comMode, cdMode :: (String -> [Delimiter]) -> String -> [Delimiter]
--
-- msMode: marked section in instance.
-- @@@ Only supports XML instance syntax (<![CDATA[ ... ]]>);
-- In SGML (and XML DTDs), parameter entity references and whitespace
-- are also allowed, in addition to INCLUDE and IGNORE keywords.
-- 'cdataMode' checks for nested occurrences of <![. this is not
-- an error according to the XML or SGML specs, but it ought to be.
--
msMode ('C':'D':'A':'T':'A':'[':rest) = cdataMode rest
msMode s =
let (ms, rest) = span ('['/=) s
in LEXERR ("Illegal marked section ["++ms) : pcdataMode (drop1 rest)
cdataMode (']':']':'>':rest) = pcdataMode rest
cdataMode ('<':'!':'[':rest) = error "Nested <![ in marked section"
cdataMode [] = []
cdataMode (c:cs) = doSpan spn (:) (CDATA . (c:)) cdataMode cs where
spn '\n' = False
spn ']' = False
spn '<' = False
spn _ = True
--
-- comMode (inside comments): [COM]
--
comMode prevMode cs = case cs of
[] -> []
'-':'-':r -> COM : cdMode prevMode r
(c:s) -> doSpan brk (:) (CDATA . (c:)) (comMode prevMode) s where
brk '-' = False
brk '\n' = False -- split long comments at line breaks
brk _ = True
-- cdMode (inside comment declarations): [COM,MDC, ignore whitespace]
cdMode prevMode cs = case cs of
[] -> []
'>':r -> MDC : prevMode r
'-':'-':r -> COM : comMode prevMode r
c:s -> if isSEPCHAR c
then cdMode prevMode (dropWhile isSEPCHAR s)
else LEXERR [c] : cdMode prevMode s
eatComment cs = case cs of
[] -> []
'-':'-':r -> markupMode r
(_:r) -> eatComment r
piMode prevMode cs = case cs of
[] -> []
'?':'>':r -> PIC : prevMode r
(c:s) -> doSpan ('?'/=) (:) (CDATA . (c:)) (piMode prevMode) s
-- EOF --