First working version

2 files changed, 972 insertions, 0 deletions

diff --git a/app/Main.hs b/app/Main.hs
new file mode 100644
index 0000000..edb7836
--- /dev/null
+++ b/app/Main.hs
@@ -0,0 +1,84 @@
+module Main (main) where
+
+import Network.XmlRpc.Internals
+import XMLParse -- Our slightly modified copy of Text.XML.HaXml.Parse
+import Data.IORef
+import System.IO
+import Text.XML.HaXml.XmlContent (fromXml)
+import Text.XML.HaXml.Lex (Token (), xmlLex)
+import Text.XML.HaXml.Types (Document (..))
+import Text.XML.HaXml.Posn (Posn ())
+import Text.ParserCombinators.Poly.State (stGet)
+import Control.Monad.Except (liftEither)
+import Text.Pandoc hiding (handleError)
+import Control.Monad (void)
+import qualified Data.ByteString.Lazy.Char8 as BSL8
+import qualified Data.Text as T
+
+type Stream = IORef [Token]
+type Callback = MethodCall -> IO MethodResponse
+
+main :: IO ()
+main = do
+  hSetBuffering stdout LineBuffering
+  handleCalls =<< newIORef =<< xmlLex "<stdin>" <$> getContents
+
+handleCalls :: Stream -> IO ()
+handleCalls stream = do
+  let callback = callbackWith stream
+  mCall <- readCall stream
+  case mCall of
+    Nothing -> return ()
+    Just call -> do
+      BSL8.putStrLn . renderResponse =<< case call of
+        MethodCall "import" [] -> handleImportCall callback
+        MethodCall "htmlize" args -> handleHtmlizeCall args
+        _ -> return (Fault 0 "Unknown method")
+      handleCalls stream
+
+readCall :: Stream -> IO (Maybe MethodCall)
+readCall streamR = do
+  stream <- readIORef streamR
+  case stream of
+    [] -> return Nothing
+    _ -> Just <$> do
+      let (xml, stream') = xmlParseWith rpcMessage stream
+      writeIORef streamR stream'
+      handleError fail $ fromXRMethodCall =<< liftEither (fromXml =<< xml)
+
+callbackWith :: Stream -> Callback
+callbackWith streamR call = do
+  BSL8.putStrLn $ renderCall call
+  (xml, stream') <- xmlParseWith rpcMessage <$> readIORef streamR
+  writeIORef streamR stream'
+  handleError fail $ fromXRMethodResponse =<< liftEither (fromXml =<< xml)
+
+-- Modified version of XMLParse.document that doesn't wait for anything after
+-- the top-level element
+rpcMessage :: XParser (Document Posn)
+rpcMessage = do
+  p <- prolog
+  e <- element
+  (_,ge) <- stGet
+  return $ Document p ge e []
+
+handleImportCall :: Callback -> IO MethodResponse
+handleImportCall callback = do
+  void $ callback $ MethodCall "hook" 
+    [ ValueString "type", ValueString "htmlize"
+    , ValueString "id",   ValueString "mdwn"
+    , ValueString "call", ValueString "htmlize"]
+  return $ Return ValueNil
+
+namedVals :: [Value] -> [(String, Value)]
+namedVals ((ValueString key):val:xs) = (key, val) : namedVals xs
+namedVals [] = []
+namedVals _ = error "arguments not in IkiWiki named-value form"
+
+handleHtmlizeCall :: [Value] -> IO MethodResponse
+handleHtmlizeCall args = 
+  either (fail . show) return . runPure $ do
+    pdoc <- readMarkdown readOpts (T.pack mdwn)
+    Return . ValueString . T.unpack <$> writeHtml5String def pdoc
+  where Just (ValueString mdwn) = lookup "content" (namedVals args)
+        readOpts = def {readerExtensions = pandocExtensions}
diff --git a/app/XMLParse.hs b/app/XMLParse.hs
new file mode 100644
index 0000000..c23f834
--- /dev/null
+++ b/app/XMLParse.hs
@@ -0,0 +1,888 @@
+{-# OPTIONS -cpp #-}
+-- A copy of Text.XML.HaXml.Parse with seemingly obvious additions to the
+-- export list
+module XMLParse
+  (
+  -- * Parse a whole document
+    xmlParse, xmlParse'
+  -- * Parse just a DTD
+  , dtdParse, dtdParse'
+  -- * Parse a partial document
+  , xmlParseWith
+  -- * Individual parsers for use with /xmlParseWith/ and module SAX
+  , document, element, content
+  , comment, cdsect, chardata
+  , reference, doctypedecl
+  , processinginstruction
+  , elemtag, qname, name, tok
+  , elemOpenTag, elemCloseTag
+  , emptySTs, XParser
+  , prolog
+  -- * These general utility functions don't belong here
+  , fst3, snd3, thd3
+  ) where
+
+-- An XML parser, written using a slightly extended version of the
+-- Hutton/Meijer parser combinators.  The input is tokenised internally
+-- by the lexer xmlLex.  Whilst parsing, we gather a symbol
+-- table of entity references.  PERefs must be defined before use, so we
+-- expand their uses as we encounter them, forcing the remainder of the
+-- input to be re-lexed and re-parsed.  GERefs are simply stored for
+-- later retrieval.
+
+import Prelude hiding (either,maybe,sequence)
+import qualified Prelude (either)
+import Data.Maybe hiding (maybe)
+import Data.List (intersperse)       -- debugging only
+import Data.Char (isSpace,isDigit,isHexDigit)
+import Control.Monad hiding (sequence)
+import Numeric (readDec,readHex)
+
+import Text.XML.HaXml.Types
+import Text.XML.HaXml.Namespaces
+import Text.XML.HaXml.Posn
+import Text.XML.HaXml.Lex
+import Text.ParserCombinators.Poly.State
+
+import System.FilePath (combine, dropFileName)
+
+
+#if ( defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 502 ) || \
+    ( defined(__NHC__) && __NHC__ > 114 ) || defined(__HUGS__)
+import System.IO.Unsafe (unsafePerformIO)
+#elif defined(__GLASGOW_HASKELL__)
+import IOExts (unsafePerformIO)
+#elif defined(__NHC__)
+import IOExtras (unsafePerformIO)
+#elif defined(__HBC__)
+import UnsafePerformIO
+#endif
+
+--  #define DEBUG
+
+#if defined(DEBUG)
+#  if ( defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 502 ) || \
+      ( defined(__NHC__) && __NHC__ > 114 ) || defined(__HUGS__)
+import Debug.Trace(trace)
+#  elif defined(__GLASGOW_HASKELL__)
+import IOExts(trace)
+#  elif defined(__NHC__) || defined(__HBC__)
+import NonStdTrace
+#  endif
+v `debug` s = trace s v
+#else
+v `debug` s = v
+#endif
+debug :: a -> String -> a
+
+
+-- | To parse a whole document, @xmlParse file content@ takes a filename
+--   (for generating error reports) and the string content of that file.
+--   A parse error causes program failure, with message to stderr.
+xmlParse :: String -> String -> Document Posn
+
+-- | To parse a whole document, @xmlParse' file content@ takes a filename
+--   (for generating error reports) and the string content of that file.
+--   Any parse error message is passed back to the caller through the
+--   @Either@ type.
+xmlParse' :: String -> String -> Either String (Document Posn)
+
+-- | To parse just a DTD, @dtdParse file content@ takes a filename
+--   (for generating error reports) and the string content of that
+--   file.  If no DTD was found, you get @Nothing@ rather than an error.
+--   However, if a DTD is found but contains errors, the program crashes.
+dtdParse  :: String -> String -> Maybe DocTypeDecl
+
+-- | To parse just a DTD, @dtdParse' file content@ takes a filename
+--   (for generating error reports) and the string content of that
+--   file.  If no DTD was found, you get @Right Nothing@.
+--   If a DTD was found but contains errors, you get a @Left message@.
+dtdParse' :: String -> String -> Either String (Maybe DocTypeDecl)
+
+xmlParse  name  = Prelude.either error id . xmlParse' name
+dtdParse  name  = Prelude.either error id . dtdParse' name
+
+xmlParse' name  = fst3 . runParser (toEOF document) emptySTs . xmlLex name
+dtdParse' name  = fst3 . runParser justDTD  emptySTs . xmlLex name
+
+toEOF :: XParser a -> XParser a
+toEOF = id	-- there are other possible implementations...
+
+-- | To parse a partial document, e.g. from an XML-based stream protocol,
+--   where you may later want to get more document elements from the same
+--   stream.  Arguments are: a parser for the item you want, and the
+--   already-lexed input to parse from.  Returns the item you wanted
+--   (or an error message), plus the remainder of the input.
+xmlParseWith :: XParser a -> [(Posn,TokenT)]
+                -> (Either String a, [(Posn,TokenT)])
+xmlParseWith p = (\(v,_,s)->(v,s)) . runParser p emptySTs
+
+
+---- Symbol table stuff ----
+
+type SymTabs = (SymTab PEDef, SymTab EntityDef)
+
+-- | Some empty symbol tables for GE and PE references.
+emptySTs :: SymTabs
+emptySTs = (emptyST, emptyST)
+
+addPE :: String -> PEDef -> SymTabs -> SymTabs
+addPE n v (pe,ge) = (addST n v pe, ge)
+
+addGE :: String -> EntityDef -> SymTabs -> SymTabs
+addGE n v (pe,ge) = let newge = addST n v ge in newge `seq` (pe, newge)
+
+lookupPE :: String -> SymTabs -> Maybe PEDef
+lookupPE s (pe,_ge) = lookupST s pe
+
+flattenEV :: EntityValue -> String
+flattenEV (EntityValue evs) = concatMap flatten evs
+  where
+    flatten (EVString s)          = s
+    flatten (EVRef (RefEntity r)) = "&" ++r++";"
+    flatten (EVRef (RefChar r))   = "&#"++show r++";"
+ -- flatten (EVPERef n)           = "%" ++n++";"
+
+
+---- Misc ----
+fst3 :: (a,b,c) -> a
+snd3 :: (a,b,c) -> b
+thd3 :: (a,b,c) -> c
+
+fst3 (a,_,_) = a
+snd3 (_,a,_) = a
+thd3 (_,_,a) = a
+
+
+---- Auxiliary Parsing Functions ----
+
+-- | XParser is just a specialisation of the PolyState parser.
+type XParser a = Parser SymTabs (Posn,TokenT) a
+
+-- | Return the next token from the input only if it matches the given token.
+tok :: TokenT -> XParser TokenT
+tok t = do (p,t') <- next
+           case t' of TokError _    -> report failBad (show t) p t'
+                      _ | t'==t     -> return t
+                        | otherwise -> report fail (show t) p t'
+nottok :: [TokenT] -> XParser TokenT
+nottok ts = do (p,t) <- next
+               if t`elem`ts then report fail ("no "++show t) p t
+                            else return t
+
+-- | Return a qualified name (although the namespace qualification is not
+--   processed here; this is merely to get the correct type).
+qname :: XParser QName
+qname = fmap N name
+
+-- | Return just a name, e.g. element name, attribute name.
+name :: XParser Name
+name = do (p,tok) <- next
+          case tok of
+            TokName s  -> return s
+            TokError _ -> report failBad "a name" p tok
+            _          -> report fail "a name" p tok
+
+string, freetext :: XParser String
+string   = do (p,t) <- next
+              case t of TokName s -> return s
+                        _         -> report fail "text" p t
+freetext = do (p,t) <- next
+              case t of TokFreeText s -> return s
+                        _             -> report fail "text" p t
+
+maybe :: XParser a -> XParser (Maybe a)
+maybe p =
+    ( p >>= return . Just) `onFail`
+    ( return Nothing)
+
+either :: XParser a -> XParser b -> XParser (Either a b)
+either p q =
+    ( p >>= return . Left) `onFail`
+    ( q >>= return . Right)
+
+word :: String -> XParser ()
+word s = do { x <- next
+            ; case x of
+                (_p,TokName n)     | s==n -> return ()
+                (_p,TokFreeText n) | s==n -> return ()
+                ( p,t@(TokError _)) -> report failBad (show s) p t
+                ( p,t) -> report fail (show s) p t
+            }
+
+posn :: XParser Posn
+posn = do { x@(p,_) <- next
+          ; reparse [x]
+          ; return p
+          }
+
+nmtoken :: XParser NmToken
+nmtoken = (string `onFail` freetext)
+
+failP, failBadP :: String -> XParser a
+failP msg = do { p <- posn; fail (msg++"\n    at "++show p) }
+failBadP msg = do { p <- posn; failBad (msg++"\n    at "++show p) }
+
+report :: (String->XParser a) -> String -> Posn -> TokenT -> XParser a
+report fail expect p t = fail ("Expected "++expect++" but found "++show t
+                               ++"\n  in "++show p)
+
+adjustErrP :: XParser a -> (String->String) -> XParser a
+p `adjustErrP` f = p `onFail` do pn <- posn
+                                 (p `adjustErr` f) `adjustErr` (++show pn)
+
+peRef :: XParser a -> XParser a
+peRef p =
+    p `onFail`
+    do pn <- posn
+       n <- pereference
+       tr <- stQuery (lookupPE n) `debug` ("Looking up %"++n)
+       case tr of
+           Just (PEDefEntityValue ev) ->
+                      do reparse (xmlReLex (posInNewCxt ("macro %"++n++";")
+                                                        (Just pn))
+                                           (flattenEV ev))
+                               `debug` ("  defn:  "++flattenEV ev)
+                         peRef p
+           Just (PEDefExternalID (PUBLIC _ (SystemLiteral f))) ->
+                      do let f' = combine (dropFileName $ posnFilename pn) f
+                             val = unsafePerformIO (readFile f')
+                         reparse (xmlReLex (posInNewCxt f'
+                                                        (Just pn)) val)
+                               `debug` ("  reading from file "++f')
+                         peRef p
+           Just (PEDefExternalID (SYSTEM (SystemLiteral f))) ->
+                      do let f' = combine (dropFileName $ posnFilename pn) f
+                             val = unsafePerformIO (readFile f')
+                         reparse (xmlReLex (posInNewCxt f'
+                                                        (Just pn)) val)
+                               `debug` ("  reading from file "++f')
+                         peRef p
+           Nothing -> fail ("PEReference use before definition: "++"%"++n++";"
+                           ++"\n    at "++show pn)
+
+blank :: XParser a -> XParser a
+blank p =
+    p `onFail`
+    do n <- pereference
+       tr <- stQuery (lookupPE n) `debug` ("Looking up %"++n++" (is blank?)")
+       case tr of
+           Just (PEDefEntityValue ev)
+                    | all isSpace (flattenEV ev)  ->
+                            do blank p `debug` "Empty macro definition"
+           Just _  -> failP ("expected a blank PERef macro: "++"%"++n++";")
+           Nothing -> failP ("PEReference use before definition: "++"%"++n++";")
+
+
+
+---- XML Parsing Functions ----
+
+justDTD :: XParser (Maybe DocTypeDecl)
+justDTD =
+  do (ExtSubset _ ds) <- extsubset `debug` "Trying external subset"
+     if null ds then fail "empty"
+         else return (Just (DTD (N "extsubset") Nothing (concatMap extract ds)))
+  `onFail`
+  do (Prolog _ _ dtd _) <- prolog
+     return dtd
+ where extract (ExtMarkupDecl m) = [m]
+       extract (ExtConditionalSect (IncludeSect i)) = concatMap extract i
+       extract (ExtConditionalSect (IgnoreSect _i)) = []
+
+-- | Return an entire XML document including prolog and trailing junk.
+document :: XParser (Document Posn)
+document = do
+    p <- prolog `adjustErr` ("unrecognisable XML prolog\n"++)
+    e <- element
+    ms <- many misc
+    (_,ge) <- stGet
+    return (Document p ge e ms)
+
+-- | Return an XML comment.
+comment :: XParser Comment
+comment = do
+    bracket (tok TokCommentOpen) (tok TokCommentClose) freetext
+--  tok TokCommentOpen
+--  commit $ do
+--    c <- freetext
+--    tok TokCommentClose
+--    return c
+
+-- | Parse a processing instruction.
+processinginstruction :: XParser ProcessingInstruction
+processinginstruction = do
+    tok TokPIOpen
+    commit $ do
+      n <- string  `onFail` failP "processing instruction has no target"
+      f <- freetext
+      tok TokPIClose `onFail` failP ("missing ?> in <?"++n)
+      return (n, f)
+
+cdsect :: XParser CDSect
+cdsect = do
+    tok TokSectionOpen
+    bracket (tok (TokSection CDATAx)) (commit $ tok TokSectionClose) chardata
+
+prolog :: XParser Prolog
+prolog = do
+    x   <- maybe xmldecl
+    m1  <- many misc
+    dtd <- maybe doctypedecl
+    m2  <- many misc
+    return (Prolog x m1 dtd m2)
+
+xmldecl :: XParser XMLDecl
+xmldecl = do
+    tok TokPIOpen
+    (word "xml" `onFail` word "XML")
+    p <- posn
+    s <- freetext
+    tok TokPIClose `onFail` failBadP "missing ?> in <?xml ...?>"
+    raise ((runParser aux emptySTs . xmlReLex p) s)
+  where
+    aux = do
+        v <- versioninfo  `onFail` failP "missing XML version info"
+        e <- maybe encodingdecl
+        s <- maybe sddecl
+        return (XMLDecl v e s)
+    raise (Left err, _, _) = failP err
+    raise (Right ok, _, _) = return ok
+
+versioninfo :: XParser VersionInfo
+versioninfo = do
+    (word "version" `onFail` word "VERSION")
+    tok TokEqual
+    bracket (tok TokQuote) (commit $ tok TokQuote) freetext
+
+misc :: XParser Misc
+misc =
+    oneOf' [ ("<!--comment-->",  comment >>= return . Comment)
+           , ("<?PI?>",          processinginstruction >>= return . PI)
+           ]
+
+-- | Return a DOCTYPE decl, indicating a DTD.
+doctypedecl :: XParser DocTypeDecl
+doctypedecl = do
+    tok TokSpecialOpen
+    tok (TokSpecial DOCTYPEx)
+    commit $ do
+      n   <- qname
+      eid <- maybe externalid
+      es  <- maybe (bracket (tok TokSqOpen) (commit $ tok TokSqClose)
+                            (many (peRef markupdecl)))
+      blank (tok TokAnyClose)  `onFail` failP "missing > in DOCTYPE decl"
+      return (DTD n eid (case es of { Nothing -> []; Just e -> e }))
+
+-- | Return a DTD markup decl, e.g. ELEMENT, ATTLIST, etc
+markupdecl :: XParser MarkupDecl
+markupdecl =
+  oneOf' [ ("ELEMENT",  elementdecl  >>= return . Element)
+         , ("ATTLIST",  attlistdecl  >>= return . AttList)
+         , ("ENTITY",   entitydecl   >>= return . Entity)
+         , ("NOTATION", notationdecl >>= return . Notation)
+         , ("misc",     misc         >>= return . MarkupMisc)
+         ]
+    `adjustErrP`
+          ("when looking for a markup decl,\n"++)
+ --       (\  (ELEMENT, ATTLIST, ENTITY, NOTATION, <!--comment-->, or <?PI?>")
+
+extsubset :: XParser ExtSubset
+extsubset = do
+    td <- maybe textdecl
+    ds <- many (peRef extsubsetdecl)
+    return (ExtSubset td ds)
+
+extsubsetdecl :: XParser ExtSubsetDecl
+extsubsetdecl =
+    ( markupdecl >>= return . ExtMarkupDecl) `onFail`
+    ( conditionalsect >>= return . ExtConditionalSect)
+
+sddecl :: XParser SDDecl
+sddecl = do
+    (word "standalone" `onFail` word "STANDALONE")
+    commit $ do
+      tok TokEqual `onFail` failP "missing = in 'standalone' decl"
+      bracket (tok TokQuote) (commit $ tok TokQuote)
+              ( (word "yes" >> return True) `onFail`
+                (word "no" >> return False) `onFail`
+                failP "'standalone' decl requires 'yes' or 'no' value" )
+
+{-
+element :: XParser (Element Posn)
+element = do
+    tok TokAnyOpen
+    (ElemTag n as) <- elemtag
+    oneOf' [ ("self-closing tag <"++n++"/>"
+             ,  do tok TokEndClose
+                   return (Elem n as []))
+           , ("after open tag <"++n++">"
+             ,  do tok TokAnyClose
+                   cs <- many content
+                   p  <- posn
+                   m  <- bracket (tok TokEndOpen) (commit $ tok TokAnyClose) qname
+                   checkmatch p n m
+                   return (Elem n as cs))
+           ] `adjustErr` (("in element tag "++n++",\n")++)
+-}
+
+-- | Return a complete element including all its inner content.
+element :: XParser (Element Posn)
+element = do
+    tok TokAnyOpen
+    (ElemTag n as) <- elemtag
+    ( do tok TokEndClose
+         commit (return (Elem n as []))
+        `onFail`
+      do tok TokAnyClose
+         commit $ do
+           return (Elem n as) `apply`
+                 manyFinally content
+                             (do p <- posn
+                                 m <- bracket (tok TokEndOpen)
+                                              (commit $ tok TokAnyClose) qname
+                                 checkmatch p n m)
+      ) `adjustErrBad` (("in element tag "++printableName n++",\n")++)
+
+checkmatch :: Posn -> QName -> QName -> XParser ()
+checkmatch p n m =
+  if n == m then return ()
+  else failBad ("tag <"++printableName n++"> terminated by </"++printableName m
+                ++">\n  at "++show p)
+
+-- | Parse only the parts between angle brackets in an element tag.
+elemtag :: XParser ElemTag
+elemtag = do
+    n  <- qname `adjustErrBad` ("malformed element tag\n"++)
+    as <- many attribute
+    return (ElemTag n as)
+
+-- | For use with stream parsers - returns the complete opening element tag.
+elemOpenTag :: XParser ElemTag
+elemOpenTag = do
+    tok TokAnyOpen
+    e <- elemtag
+    tok TokAnyClose
+    return e
+
+-- | For use with stream parsers - accepts a closing tag, provided it
+--   matches the given element name.
+elemCloseTag :: QName -> XParser ()
+elemCloseTag n = do
+    tok TokEndOpen
+    p <- posn
+    m <- qname
+    tok TokAnyClose
+    checkmatch p n m
+
+attribute :: XParser Attribute
+attribute = do
+    n <- qname `adjustErr` ("malformed attribute name\n"++)
+    tok TokEqual `onFail` failBadP "missing = in attribute"
+    v <- attvalue `onFail` failBadP "missing attvalue"
+    return (n,v)
+
+-- | Return a content particle, e.g. text, element, reference, etc
+content :: XParser (Content Posn)
+content =
+  do { p  <- posn
+     ; c' <- content'
+     ; return (c' p)
+     }
+  where
+     content' = oneOf' [ ("element",   element   >>= return . CElem)
+                       , ("chardata",  chardata  >>= return . CString False)
+                       , ("reference", reference >>= return . CRef)
+                       , ("CDATA",     cdsect    >>= return . CString True)
+                       , ("misc",      misc      >>= return . CMisc)
+                       ]
+                  `adjustErrP` ("when looking for a content item,\n"++)
+-- (\    (element, text, reference, CDATA section, <!--comment-->, or <?PI?>")
+
+elementdecl :: XParser ElementDecl
+elementdecl = do
+    tok TokSpecialOpen
+    tok (TokSpecial ELEMENTx)
+    n <- peRef qname `adjustErrBad` ("expecting identifier in ELEMENT decl\n"++)
+    c <- peRef contentspec
+             `adjustErrBad` (("in content spec of ELEMENT decl: "
+                              ++printableName n++"\n")++)
+    blank (tok TokAnyClose) `onFail` failBadP
+       ("expected > terminating ELEMENT decl"
+       ++"\n    element name was "++show (printableName n)
+       ++"\n    contentspec was "++(\ (ContentSpec p)-> debugShowCP p) c)
+    return (ElementDecl n c)
+
+contentspec :: XParser ContentSpec
+contentspec =
+    oneOf' [ ("EMPTY",  peRef (word "EMPTY") >> return EMPTY)
+           , ("ANY",    peRef (word "ANY") >> return ANY)
+           , ("mixed",  peRef mixed >>= return . Mixed)
+           , ("simple", peRef cp >>= return . ContentSpec)
+           ]
+ --   `adjustErr` ("when looking for content spec,\n"++)
+ --   `adjustErr` (++"\nLooking for content spec (EMPTY, ANY, mixed, etc)")
+
+choice :: XParser [CP]
+choice = do
+    bracket (tok TokBraOpen `debug` "Trying choice")
+            (blank (tok TokBraClose `debug` "Succeeded with choice"))
+            (peRef cp `sepBy1` blank (tok TokPipe))
+
+sequence :: XParser [CP]
+sequence = do
+    bracket (tok TokBraOpen `debug` "Trying sequence")
+            (blank (tok TokBraClose `debug` "Succeeded with sequence"))
+            (peRef cp `sepBy1` blank (tok TokComma))
+
+cp :: XParser CP
+cp = oneOf [ ( do n <- qname
+                  m <- modifier
+                  let c = TagName n m
+                  return c `debug` ("ContentSpec: name "++debugShowCP c))
+           , ( do ss <- sequence
+                  m <- modifier
+                  let c = Seq ss m
+                  return c `debug` ("ContentSpec: sequence "++debugShowCP c))
+           , ( do cs <- choice
+                  m <- modifier
+                  let c = Choice cs m
+                  return c `debug` ("ContentSpec: choice "++debugShowCP c))
+           ] `adjustErr` (++"\nwhen looking for a content particle")
+
+modifier :: XParser Modifier
+modifier = oneOf [ ( tok TokStar >> return Star )
+                 , ( tok TokQuery >> return Query )
+                 , ( tok TokPlus >> return Plus )
+                 , ( return None )
+                 ]
+
+-- just for debugging
+debugShowCP :: CP -> String
+debugShowCP cp = case cp of
+    TagName n m  -> printableName n++debugShowModifier m
+    Choice cps m -> '(': concat (intersperse "|" (map debugShowCP cps))++")"++debugShowModifier m
+    Seq cps m    -> '(': concat (intersperse "," (map debugShowCP cps))++")"++debugShowModifier m
+debugShowModifier :: Modifier -> String
+debugShowModifier modifier = case modifier of
+    None  -> ""
+    Query -> "?"
+    Star  -> "*"
+    Plus  -> "+"
+----
+
+mixed :: XParser Mixed
+mixed = do
+    tok TokBraOpen
+    peRef (do tok TokHash
+              word "PCDATA")
+    commit $
+      oneOf [ ( do cs <- many (peRef (do tok TokPipe
+                                         peRef qname))
+                   blank (tok TokBraClose >> tok TokStar)
+                   return (PCDATAplus cs))
+            , ( blank (tok TokBraClose >> tok TokStar) >> return PCDATA)
+            , ( blank (tok TokBraClose) >> return PCDATA)
+            ]
+        `adjustErrP` (++"\nLooking for mixed content spec (#PCDATA | ...)*\n")
+
+attlistdecl :: XParser AttListDecl
+attlistdecl = do
+    tok TokSpecialOpen
+    tok (TokSpecial ATTLISTx)
+    n <- peRef qname `adjustErrBad` ("expecting identifier in ATTLIST\n"++)
+    ds <- peRef (many1 (peRef attdef))
+    blank (tok TokAnyClose) `onFail` failBadP "missing > terminating ATTLIST"
+    return (AttListDecl n ds)
+
+attdef :: XParser AttDef
+attdef =
+  do n <- peRef qname `adjustErr` ("expecting attribute name\n"++)
+     t <- peRef atttype `adjustErr` (("within attlist defn: "
+                                     ++printableName n++",\n")++)
+     d <- peRef defaultdecl `adjustErr` (("in attlist defn: "
+                                         ++printableName n++",\n")++)
+     return (AttDef n t d)
+
+atttype :: XParser AttType
+atttype =
+    oneOf' [ ("CDATA",      word "CDATA" >> return StringType)
+           , ("tokenized",  tokenizedtype >>= return . TokenizedType)
+           , ("enumerated", enumeratedtype >>= return . EnumeratedType)
+           ]
+      `adjustErr` ("looking for ATTTYPE,\n"++)
+ --   `adjustErr` (++"\nLooking for ATTTYPE (CDATA, tokenized, or enumerated")
+
+tokenizedtype :: XParser TokenizedType
+tokenizedtype =
+    oneOf [ ( word "ID" >> return ID)
+          , ( word "IDREF" >> return IDREF)
+          , ( word "IDREFS" >> return IDREFS)
+          , ( word "ENTITY" >> return ENTITY)
+          , ( word "ENTITIES" >> return ENTITIES)
+          , ( word "NMTOKEN" >> return NMTOKEN)
+          , ( word "NMTOKENS" >> return NMTOKENS)
+          ] `onFail`
+    do { t <- next
+       ; failP ("Expected one of"
+               ++" (ID, IDREF, IDREFS, ENTITY, ENTITIES, NMTOKEN, NMTOKENS)"
+               ++"\nbut got "++show t)
+       }
+
+enumeratedtype :: XParser EnumeratedType
+enumeratedtype =
+    oneOf' [ ("NOTATION",   notationtype >>= return . NotationType)
+           , ("enumerated", enumeration >>= return . Enumeration)
+           ]
+      `adjustErr` ("looking for an enumerated or NOTATION type,\n"++)
+
+notationtype :: XParser NotationType
+notationtype = do
+    word "NOTATION"
+    bracket (tok TokBraOpen) (commit $ blank $ tok TokBraClose)
+            (peRef name `sepBy1` peRef (tok TokPipe))
+
+enumeration :: XParser Enumeration
+enumeration =
+    bracket (tok TokBraOpen) (commit $ blank $ tok TokBraClose)
+            (peRef nmtoken `sepBy1` blank (peRef (tok TokPipe)))
+
+defaultdecl :: XParser DefaultDecl
+defaultdecl =
+    oneOf' [ ("REQUIRED",  tok TokHash >> word "REQUIRED" >> return REQUIRED)
+           , ("IMPLIED",   tok TokHash >> word "IMPLIED" >> return IMPLIED)
+           , ("FIXED",     do f <- maybe (tok TokHash >> word "FIXED"
+                                                      >> return FIXED)
+                              a <- peRef attvalue
+                              return (DefaultTo a f) )
+           ]
+        `adjustErr` ("looking for an attribute default decl,\n"++)
+
+conditionalsect :: XParser ConditionalSect
+conditionalsect = oneOf'
+    [ ( "INCLUDE"
+      , do tok TokSectionOpen
+           peRef (tok (TokSection INCLUDEx))
+           p <- posn
+           tok TokSqOpen `onFail` failBadP "missing [ after INCLUDE"
+           i <- many (peRef extsubsetdecl)
+           tok TokSectionClose
+                   `onFail` failBadP ("missing ]]> for INCLUDE section"
+                                     ++"\n    begun at "++show p)
+           return (IncludeSect i))
+    , ( "IGNORE"
+      , do tok TokSectionOpen
+           peRef (tok (TokSection IGNOREx))
+           p <- posn
+           tok TokSqOpen `onFail` failBadP "missing [ after IGNORE"
+           many newIgnore  -- many ignoresectcontents
+           tok TokSectionClose
+                   `onFail` failBadP ("missing ]]> for IGNORE section"
+                                     ++"\n    begun at "++show p)
+           return (IgnoreSect []))
+    ] `adjustErr` ("in a conditional section,\n"++)
+
+newIgnore :: XParser Ignore
+newIgnore =
+    ( do tok TokSectionOpen
+         many newIgnore `debug` "IGNORING conditional section"
+         tok TokSectionClose
+         return Ignore `debug` "end of IGNORED conditional section") `onFail`
+    ( do t <- nottok [TokSectionOpen,TokSectionClose]
+         return Ignore  `debug` ("ignoring: "++show t))
+
+--- obsolete?
+--ignoresectcontents :: XParser IgnoreSectContents
+--ignoresectcontents = do
+--    i <- ignore
+--    is <- many (do tok TokSectionOpen
+--                   ic <- ignoresectcontents
+--                   tok TokSectionClose
+--                   ig <- ignore
+--                   return (ic,ig))
+--    return (IgnoreSectContents i is)
+--
+--ignore :: XParser Ignore
+--ignore = do
+--  is <- many1 (nottok [TokSectionOpen,TokSectionClose])
+--  return Ignore  `debug` ("ignored all of: "++show is)
+----
+
+-- | Return either a general entity reference, or a character reference.
+reference :: XParser Reference
+reference = do
+    bracket (tok TokAmp) (tok TokSemi) (freetext >>= val)
+  where
+    val ('#':'x':i) | all isHexDigit i
+                    = return . RefChar . fst . head . readHex $ i
+    val ('#':i)     | all isDigit i
+                    = return . RefChar . fst . head . readDec $ i
+    val name        = return . RefEntity $ name
+
+{- -- following is incorrect
+reference =
+    ( charref >>= return . RefChar) `onFail`
+    ( entityref >>= return . RefEntity)
+
+entityref :: XParser EntityRef
+entityref = do
+    bracket (tok TokAmp) (commit $ tok TokSemi) name
+
+charref :: XParser CharRef
+charref = do
+    bracket (tok TokAmp) (commit $ tok TokSemi) (freetext >>= readCharVal)
+  where
+    readCharVal ('#':'x':i) = return . fst . head . readHex $ i
+    readCharVal ('#':i)     = return . fst . head . readDec $ i
+    readCharVal _           = mzero
+-}
+
+pereference :: XParser PEReference
+pereference = do
+    bracket (tok TokPercent) (tok TokSemi) nmtoken
+
+entitydecl :: XParser EntityDecl
+entitydecl =
+    ( gedecl >>= return . EntityGEDecl) `onFail`
+    ( pedecl >>= return . EntityPEDecl)
+
+gedecl :: XParser GEDecl
+gedecl = do
+    tok TokSpecialOpen
+    tok (TokSpecial ENTITYx)
+    n <- name
+    e <- entitydef `adjustErrBad` (("in general entity defn "++n++",\n")++)
+    tok TokAnyClose `onFail` failBadP ("expected > terminating G ENTITY decl "++n)
+    stUpdate (addGE n e) `debug` ("added GE defn &"++n++";")
+    return (GEDecl n e)
+
+pedecl :: XParser PEDecl
+pedecl = do
+    tok TokSpecialOpen
+    tok (TokSpecial ENTITYx)
+    tok TokPercent
+    n <- name
+    e <- pedef `adjustErrBad` (("in parameter entity defn "++n++",\n")++)
+    tok TokAnyClose `onFail` failBadP ("expected > terminating P ENTITY decl "++n)
+    stUpdate (addPE n e) `debug` ("added PE defn %"++n++";\n"++show e)
+    return (PEDecl n e)
+
+entitydef :: XParser EntityDef
+entitydef =
+    oneOf' [ ("entityvalue", entityvalue >>= return . DefEntityValue)
+           , ("external",    do eid <- externalid
+                                ndd <- maybe ndatadecl
+                                return (DefExternalID eid ndd))
+           ]
+
+pedef :: XParser PEDef
+pedef =
+    oneOf' [ ("entityvalue", entityvalue >>= return . PEDefEntityValue)
+           , ("externalid",  externalid  >>= return . PEDefExternalID)
+           ]
+
+externalid :: XParser ExternalID
+externalid =
+    oneOf' [ ("SYSTEM", do word "SYSTEM"
+                           s <- systemliteral
+                           return (SYSTEM s) )
+           , ("PUBLIC", do word "PUBLIC"
+                           p <- pubidliteral
+                           s <- systemliteral
+                           return (PUBLIC p s) )
+           ]
+      `adjustErr` ("looking for an external id,\n"++)
+
+ndatadecl :: XParser NDataDecl
+ndatadecl = do
+    word "NDATA"
+    n <- name
+    return (NDATA n)
+
+textdecl :: XParser TextDecl
+textdecl = do
+    tok TokPIOpen
+    (word "xml" `onFail` word "XML")
+    v <- maybe versioninfo
+    e <- encodingdecl
+    tok TokPIClose `onFail` failP "expected ?> terminating text decl"
+    return (TextDecl v e)
+
+--extparsedent :: XParser (ExtParsedEnt Posn)
+--extparsedent = do
+--    t <- maybe textdecl
+--    c <- content
+--    return (ExtParsedEnt t c)
+--
+--extpe :: XParser ExtPE
+--extpe = do
+--    t <- maybe textdecl
+--    e <- many (peRef extsubsetdecl)
+--    return (ExtPE t e)
+
+encodingdecl :: XParser EncodingDecl
+encodingdecl = do
+    (word "encoding" `onFail` word "ENCODING")
+    tok TokEqual `onFail` failBadP "expected = in 'encoding' decl"
+    f <- bracket (tok TokQuote) (commit $ tok TokQuote) freetext
+    return (EncodingDecl f)
+
+notationdecl :: XParser NotationDecl
+notationdecl = do
+    tok TokSpecialOpen
+    tok (TokSpecial NOTATIONx)
+    n <- name
+    e <- either externalid publicid
+    tok TokAnyClose `onFail` failBadP ("expected > terminating NOTATION decl "++n)
+    return (NOTATION n e)
+
+publicid :: XParser PublicID
+publicid = do
+    word "PUBLIC"
+    p <- pubidliteral
+    return (PUBLICID p)
+
+entityvalue :: XParser EntityValue
+entityvalue = do
+ -- evs <- bracket (tok TokQuote) (commit $ tok TokQuote) (many (peRef ev))
+    tok TokQuote
+    pn <- posn
+    evs <- many ev
+    tok TokQuote `onFail` failBadP "expected quote to terminate entityvalue"
+    -- quoted text must be rescanned for possible PERefs
+    st <- stGet
+    Prelude.either failBad (return . EntityValue) . fst3 $
+                (runParser (many ev) st
+                         (reLexEntityValue (\s-> stringify (lookupPE s st))
+                                           pn
+                                           (flattenEV (EntityValue evs))))
+  where
+    stringify (Just (PEDefEntityValue ev)) = Just (flattenEV ev)
+    stringify _ = Nothing
+
+ev :: XParser EV
+ev =
+    oneOf' [ ("string",    (string`onFail`freetext) >>= return . EVString)
+           , ("reference", reference >>= return . EVRef)
+           ]
+      `adjustErr` ("looking for entity value,\n"++)
+
+attvalue :: XParser AttValue
+attvalue = do
+    avs <- bracket (tok TokQuote) (commit $ tok TokQuote)
+                   (many (either freetext reference))
+    return (AttValue avs)
+
+systemliteral :: XParser SystemLiteral
+systemliteral = do
+    s <- bracket (tok TokQuote) (commit $ tok TokQuote) freetext
+    return (SystemLiteral s)            -- note: refs &...; not permitted
+
+pubidliteral :: XParser PubidLiteral
+pubidliteral = do
+    s <- bracket (tok TokQuote) (commit $ tok TokQuote) freetext
+    return (PubidLiteral s)             -- note: freetext is too liberal here
+
+-- | Return parsed freetext (i.e. until the next markup)
+chardata :: XParser CharData
+chardata = freetext
+