-- | The class 'XmlContent' is a kind of replacement for Read and Show:
--   it provides conversions between a generic XML tree representation
--   and your own more specialised typeful Haskell data trees.
--
--   If you are starting with a set of Haskell datatypes, use DrIFT to
--   derive instances of this class for you:
--       http:\/\/repetae.net\/john\/computer\/haskell\/DrIFT
--   and use the current module for instances of the standard Haskell
--   datatypes list, Maybe, and so on.
--
--   If you are starting with an XML DTD, use HaXml's tool DtdToHaskell
--   to generate both the Haskell types and the corresponding instances,
--   but _do_not_ use the current module for instances: use
--   Text.XML.HaXml.XmlContent instead.

module Text.XML.HaXml.XmlContent.Haskell
  (
  -- * Re-export everything from Text.XML.HaXml.XmlContent.Parser.
    module Text.XML.HaXml.XmlContent.Parser
  -- * Instances (only) for the XmlContent class, for datatypes that
  --   originated in Haskell, rather than from a DTD definition.
--  , module Text.XML.HaXml.XmlContent.Haskell

  -- * Whole-document conversion functions
  , toXml, fromXml
  , readXml, showXml, fpsShowXml
  , fReadXml, fWriteXml, fpsWriteXml
  , hGetXml,  hPutXml, fpsHPutXml

  ) where

import System.IO
import Data.List (isPrefixOf, isSuffixOf)
import qualified Text.XML.HaXml.ByteStringPP as FPS (document)
import qualified Data.ByteString.Lazy.Char8 as FPS

import Text.PrettyPrint.HughesPJ (render)
import Text.ParserCombinators.Poly

import Text.XML.HaXml.Types
import Text.XML.HaXml.Namespaces
import Text.XML.HaXml.TypeMapping
import Text.XML.HaXml.Posn     (Posn, posInNewCxt)
import Text.XML.HaXml.Pretty   (document)
import Text.XML.HaXml.Parse    (xmlParse)
import Text.XML.HaXml.Verbatim (Verbatim(verbatim))
import Text.XML.HaXml.XmlContent.Parser


        -- probably want to write DTD separately from value, and have
        -- easy ways to combine DTD + value into a document, or write
        -- them to separate files.

-- | Read an XML document from a file and convert it to a fully-typed
--   Haskell value.
fReadXml  :: XmlContent a => FilePath -> IO a
fReadXml :: FilePath -> IO a
fReadXml fp :: FilePath
fp = do
    Handle
f <- ( if FilePath
fpFilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
=="-" then Handle -> IO Handle
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
stdin
           else FilePath -> IOMode -> IO Handle
openFile FilePath
fp IOMode
ReadMode )
    FilePath
x <- Handle -> IO FilePath
hGetContents Handle
f
    let (Document _ _ y :: Element Posn
y _) = FilePath -> FilePath -> Document Posn
xmlParse FilePath
fp FilePath
x
        y' :: Content Posn
y' = Element Posn -> Posn -> Content Posn
forall i. Element i -> i -> Content i
CElem Element Posn
y (FilePath -> Maybe Posn -> Posn
posInNewCxt FilePath
fp Maybe Posn
forall a. Maybe a
Nothing)
    (FilePath -> IO a) -> (a -> IO a) -> Either FilePath a -> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Either FilePath a, [Content Posn]) -> Either FilePath a
forall a b. (a, b) -> a
fst (Parser (Content Posn) a
-> [Content Posn] -> (Either FilePath a, [Content Posn])
forall t a. Parser t a -> [t] -> (Either FilePath a, [t])
runParser Parser (Content Posn) a
forall a. XmlContent a => XMLParser a
parseContents [Content Posn
y']))

-- | Write a fully-typed Haskell value to the given file as an XML
--   document.
fWriteXml :: XmlContent a => FilePath -> a -> IO ()
fWriteXml :: FilePath -> a -> IO ()
fWriteXml fp :: FilePath
fp x :: a
x = do
    Handle
f <- ( if FilePath
fpFilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
=="-" then Handle -> IO Handle
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
stdout
           else FilePath -> IOMode -> IO Handle
openFile FilePath
fp IOMode
WriteMode )
    Handle -> Bool -> a -> IO ()
forall a. XmlContent a => Handle -> Bool -> a -> IO ()
hPutXml Handle
f Bool
False a
x
    Handle -> IO ()
hClose Handle
f

-- | Write any Haskell value to the given file as an XML document,
--   using the FastPackedString interface (output will not be prettified).
fpsWriteXml :: XmlContent a => FilePath -> a -> IO ()
fpsWriteXml :: FilePath -> a -> IO ()
fpsWriteXml fp :: FilePath
fp x :: a
x = do
    Handle
f <- ( if FilePath
fpFilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
=="-" then Handle -> IO Handle
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
stdout
           else FilePath -> IOMode -> IO Handle
openFile FilePath
fp IOMode
WriteMode )
    Handle -> Bool -> a -> IO ()
forall a. XmlContent a => Handle -> Bool -> a -> IO ()
fpsHPutXml Handle
f Bool
False a
x
    Handle -> IO ()
hClose Handle
f

-- | Read a fully-typed XML document from a string.
readXml :: XmlContent a => String -> Either String a
readXml :: FilePath -> Either FilePath a
readXml s :: FilePath
s =
    let (Document _ _ y :: Element Posn
y _) = FilePath -> FilePath -> Document Posn
xmlParse "string input" FilePath
s in
    (Either FilePath a, [Content Posn]) -> Either FilePath a
forall a b. (a, b) -> a
fst (Parser (Content Posn) a
-> [Content Posn] -> (Either FilePath a, [Content Posn])
forall t a. Parser t a -> [t] -> (Either FilePath a, [t])
runParser Parser (Content Posn) a
forall a. XmlContent a => XMLParser a
parseContents
                   [Element Posn -> Posn -> Content Posn
forall i. Element i -> i -> Content i
CElem Element Posn
y (FilePath -> Maybe Posn -> Posn
posInNewCxt "string input" Maybe Posn
forall a. Maybe a
Nothing)])

-- | Convert a fully-typed XML document to a string (without DTD).
showXml :: XmlContent a => Bool -> a -> String
showXml :: Bool -> a -> FilePath
showXml dtd :: Bool
dtd x :: a
x =
    case a -> [Content ()]
forall a. XmlContent a => a -> [Content ()]
toContents a
x of
      [CElem _ _] -> (Doc -> FilePath
render (Doc -> FilePath) -> (a -> Doc) -> a -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Document () -> Doc
forall i. Document i -> Doc
document (Document () -> Doc) -> (a -> Document ()) -> a -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> a -> Document ()
forall a. XmlContent a => Bool -> a -> Document ()
toXml Bool
dtd) a
x
      _ -> ""

-- | Convert a fully-typed XML document to a ByteString (without DTD).
fpsShowXml :: XmlContent a => Bool -> a -> FPS.ByteString
fpsShowXml :: Bool -> a -> ByteString
fpsShowXml dtd :: Bool
dtd x :: a
x =
    case a -> [Content ()]
forall a. XmlContent a => a -> [Content ()]
toContents a
x of
      [CElem _ _] -> (Document () -> ByteString
forall i. Document i -> ByteString
FPS.document (Document () -> ByteString)
-> (a -> Document ()) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> a -> Document ()
forall a. XmlContent a => Bool -> a -> Document ()
toXml Bool
dtd) a
x
      _ -> ByteString
FPS.empty


-- | Convert a fully-typed XML document to a string (with or without DTD).
toXml :: XmlContent a => Bool -> a -> Document ()
toXml :: Bool -> a -> Document ()
toXml dtd :: Bool
dtd value :: a
value =
    let ht :: HType
ht = a -> HType
forall a. HTypeable a => a -> HType
toHType a
value in
    Prolog -> SymTab EntityDef -> Element () -> [Misc] -> Document ()
forall i.
Prolog -> SymTab EntityDef -> Element i -> [Misc] -> Document i
Document (Maybe XMLDecl -> [Misc] -> Maybe DocTypeDecl -> [Misc] -> Prolog
Prolog (XMLDecl -> Maybe XMLDecl
forall a. a -> Maybe a
Just (FilePath -> Maybe EncodingDecl -> Maybe Bool -> XMLDecl
XMLDecl "1.0" Maybe EncodingDecl
forall a. Maybe a
Nothing Maybe Bool
forall a. Maybe a
Nothing))
                     [] (if Bool
dtd then DocTypeDecl -> Maybe DocTypeDecl
forall a. a -> Maybe a
Just (HType -> DocTypeDecl
toDTD HType
ht) else Maybe DocTypeDecl
forall a. Maybe a
Nothing) [])
             SymTab EntityDef
forall a. SymTab a
emptyST
             ( case (HType
ht, a -> [Content ()]
forall a. XmlContent a => a -> [Content ()]
toContents a
value) of
                 (Tuple _, cs :: [Content ()]
cs)       -> QName -> [Attribute] -> [Content ()] -> Element ()
forall i. QName -> [Attribute] -> [Content i] -> Element i
Elem (FilePath -> QName
N (FilePath -> QName) -> FilePath -> QName
forall a b. (a -> b) -> a -> b
$ HType -> ShowS
showHType HType
ht "") [] [Content ()]
cs
                 (Defined _ _ _, cs :: [Content ()]
cs) -> QName -> [Attribute] -> [Content ()] -> Element ()
forall i. QName -> [Attribute] -> [Content i] -> Element i
Elem (FilePath -> QName
N (FilePath -> QName) -> FilePath -> QName
forall a b. (a -> b) -> a -> b
$ HType -> ShowS
showHType HType
ht "-XML") [] [Content ()]
cs
                 (_, [CElem e :: Element ()
e ()])   -> Element ()
e )
             []

-- | Read a Haskell value from an XML document, ignoring the DTD and
--   using the Haskell result type to determine how to parse it.
fromXml :: XmlContent a => Document Posn -> Either String a
fromXml :: Document Posn -> Either FilePath a
fromXml (Document _ _ e :: Element Posn
e@(Elem n :: QName
n _ cs :: [Content Posn]
cs) _)
  | "tuple" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` QName -> FilePath
localName QName
n = (Either FilePath a, [Content Posn]) -> Either FilePath a
forall a b. (a, b) -> a
fst (Parser (Content Posn) a
-> [Content Posn] -> (Either FilePath a, [Content Posn])
forall t a. Parser t a -> [t] -> (Either FilePath a, [t])
runParser Parser (Content Posn) a
forall a. XmlContent a => XMLParser a
parseContents [Content Posn]
cs)
  | "-XML"  FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` QName -> FilePath
localName QName
n = (Either FilePath a, [Content Posn]) -> Either FilePath a
forall a b. (a, b) -> a
fst (Parser (Content Posn) a
-> [Content Posn] -> (Either FilePath a, [Content Posn])
forall t a. Parser t a -> [t] -> (Either FilePath a, [t])
runParser Parser (Content Posn) a
forall a. XmlContent a => XMLParser a
parseContents [Content Posn]
cs)
  | Bool
otherwise = (Either FilePath a, [Content Posn]) -> Either FilePath a
forall a b. (a, b) -> a
fst (Parser (Content Posn) a
-> [Content Posn] -> (Either FilePath a, [Content Posn])
forall t a. Parser t a -> [t] -> (Either FilePath a, [t])
runParser Parser (Content Posn) a
forall a. XmlContent a => XMLParser a
parseContents
                               [Element Posn -> Posn -> Content Posn
forall i. Element i -> i -> Content i
CElem Element Posn
e (FilePath -> Maybe Posn -> Posn
posInNewCxt "document" Maybe Posn
forall a. Maybe a
Nothing)])


-- | Read a fully-typed XML document from a file handle.
hGetXml :: XmlContent a => Handle -> IO a
hGetXml :: Handle -> IO a
hGetXml h :: Handle
h = do
    FilePath
x <- Handle -> IO FilePath
hGetContents Handle
h
    let (Document _ _ y :: Element Posn
y _) = FilePath -> FilePath -> Document Posn
xmlParse "file handle" FilePath
x
    (FilePath -> IO a) -> (a -> IO a) -> Either FilePath a -> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
           ((Either FilePath a, [Content Posn]) -> Either FilePath a
forall a b. (a, b) -> a
fst (Parser (Content Posn) a
-> [Content Posn] -> (Either FilePath a, [Content Posn])
forall t a. Parser t a -> [t] -> (Either FilePath a, [t])
runParser Parser (Content Posn) a
forall a. XmlContent a => XMLParser a
parseContents
                           [Element Posn -> Posn -> Content Posn
forall i. Element i -> i -> Content i
CElem Element Posn
y (FilePath -> Maybe Posn -> Posn
posInNewCxt "file handle" Maybe Posn
forall a. Maybe a
Nothing)]))

-- | Write a fully-typed XML document to a file handle.
hPutXml :: XmlContent a => Handle -> Bool -> a -> IO ()
hPutXml :: Handle -> Bool -> a -> IO ()
hPutXml h :: Handle
h dtd :: Bool
dtd x :: a
x = do
    (Handle -> FilePath -> IO ()
hPutStrLn Handle
h (FilePath -> IO ()) -> (a -> FilePath) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> FilePath
render (Doc -> FilePath) -> (a -> Doc) -> a -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Document () -> Doc
forall i. Document i -> Doc
document (Document () -> Doc) -> (a -> Document ()) -> a -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> a -> Document ()
forall a. XmlContent a => Bool -> a -> Document ()
toXml Bool
dtd) a
x

-- | Write a fully-typed XML document to a file handle, using the
--   FastPackedString interface (output will not be prettified).
fpsHPutXml :: XmlContent a => Handle -> Bool -> a -> IO ()
fpsHPutXml :: Handle -> Bool -> a -> IO ()
fpsHPutXml h :: Handle
h dtd :: Bool
dtd x :: a
x = do
    (Handle -> ByteString -> IO ()
FPS.hPut Handle
h (ByteString -> IO ()) -> (a -> ByteString) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Document () -> ByteString
forall i. Document i -> ByteString
FPS.document (Document () -> ByteString)
-> (a -> Document ()) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> a -> Document ()
forall a. XmlContent a => Bool -> a -> Document ()
toXml Bool
dtd) a
x


------------------------------------------------------------------------
-- Instances for all the standard basic datatypes.
-- These are for Haskell datatypes being derived to go to XML.
-- DtdToHaskell does not use these instances.
------------------------------------------------------------------------

instance XmlContent Bool where
    toContents :: Bool -> [Content ()]
toContents b :: Bool
b   = [Element () -> () -> Content ()
forall i. Element i -> i -> Content i
CElem (QName -> [Attribute] -> [Content ()] -> Element ()
forall i. QName -> [Attribute] -> [Content i] -> Element i
Elem (FilePath -> QName
N "bool") [FilePath -> FilePath -> Attribute
mkAttr "value" (Bool -> FilePath
forall a. Show a => a -> FilePath
show Bool
b)] []) ()]
    parseContents :: XMLParser Bool
parseContents = do { Element Posn
e <- [FilePath] -> XMLParser (Element Posn)
element ["bool"] ; Bool -> XMLParser Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Element Posn -> Bool
forall a i. Read a => Element i -> a
attval Element Posn
e) }

instance XmlContent Int where
    toContents :: Int -> [Content ()]
toContents i :: Int
i   = [Element () -> () -> Content ()
forall i. Element i -> i -> Content i
CElem (QName -> [Attribute] -> [Content ()] -> Element ()
forall i. QName -> [Attribute] -> [Content i] -> Element i
Elem (FilePath -> QName
N "int") [FilePath -> FilePath -> Attribute
mkAttr "value" (Int -> FilePath
forall a. Show a => a -> FilePath
show Int
i)] []) ()]
    parseContents :: XMLParser Int
parseContents = do { Element Posn
e <- [FilePath] -> XMLParser (Element Posn)
element ["int"] ; Int -> XMLParser Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Element Posn -> Int
forall a i. Read a => Element i -> a
attval Element Posn
e) }

instance XmlContent Integer where
    toContents :: Integer -> [Content ()]
toContents i :: Integer
i   = [Element () -> () -> Content ()
forall i. Element i -> i -> Content i
CElem (QName -> [Attribute] -> [Content ()] -> Element ()
forall i. QName -> [Attribute] -> [Content i] -> Element i
Elem (FilePath -> QName
N "integer") [FilePath -> FilePath -> Attribute
mkAttr "value" (Integer -> FilePath
forall a. Show a => a -> FilePath
show Integer
i)] []) ()]
    parseContents :: XMLParser Integer
parseContents = do { Element Posn
e <- [FilePath] -> XMLParser (Element Posn)
element ["integer"] ; Integer -> XMLParser Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Element Posn -> Integer
forall a i. Read a => Element i -> a
attval Element Posn
e) }

instance XmlContent Float where
    toContents :: Float -> [Content ()]
toContents i :: Float
i   = [Element () -> () -> Content ()
forall i. Element i -> i -> Content i
CElem (QName -> [Attribute] -> [Content ()] -> Element ()
forall i. QName -> [Attribute] -> [Content i] -> Element i
Elem (FilePath -> QName
N "float") [FilePath -> FilePath -> Attribute
mkAttr "value" (Float -> FilePath
forall a. Show a => a -> FilePath
show Float
i)] []) ()]
    parseContents :: XMLParser Float
parseContents = do { Element Posn
e <- [FilePath] -> XMLParser (Element Posn)
element ["float"] ; Float -> XMLParser Float
forall (m :: * -> *) a. Monad m => a -> m a
return (Element Posn -> Float
forall a i. Read a => Element i -> a
attval Element Posn
e) }

instance XmlContent Double where
    toContents :: Double -> [Content ()]
toContents i :: Double
i   = [Element () -> () -> Content ()
forall i. Element i -> i -> Content i
CElem (QName -> [Attribute] -> [Content ()] -> Element ()
forall i. QName -> [Attribute] -> [Content i] -> Element i
Elem (FilePath -> QName
N "double") [FilePath -> FilePath -> Attribute
mkAttr "value" (Double -> FilePath
forall a. Show a => a -> FilePath
show Double
i)] []) ()]
    parseContents :: XMLParser Double
parseContents = do { Element Posn
e <- [FilePath] -> XMLParser (Element Posn)
element ["double"] ; Double -> XMLParser Double
forall (m :: * -> *) a. Monad m => a -> m a
return (Element Posn -> Double
forall a i. Read a => Element i -> a
attval Element Posn
e) }

instance XmlContent Char where
    -- NOT in a string
    toContents :: Char -> [Content ()]
toContents c :: Char
c   = [Element () -> () -> Content ()
forall i. Element i -> i -> Content i
CElem (QName -> [Attribute] -> [Content ()] -> Element ()
forall i. QName -> [Attribute] -> [Content i] -> Element i
Elem (FilePath -> QName
N "char") [FilePath -> FilePath -> Attribute
mkAttr "value" [Char
c]] []) ()]
    parseContents :: XMLParser Char
parseContents = do { (Elem _ [(N "value",(AttValue [Left [c :: Char
c]]))] [])
                             <- [FilePath] -> XMLParser (Element Posn)
element ["char"]
                       ; Char -> XMLParser Char
forall (m :: * -> *) a. Monad m => a -> m a
return Char
c
                       }
    -- Only defined for Char and no other types:
    xToChar :: Char -> Char
xToChar   = Char -> Char
forall a. a -> a
id
    xFromChar :: Char -> Char
xFromChar = Char -> Char
forall a. a -> a
id

instance XmlContent a => XmlContent [a] where
    toContents :: [a] -> [Content ()]
toContents xs :: [a]
xs  = case a -> HType
forall a. HTypeable a => a -> HType
toHType a
x of
                       (Prim "Char" _) ->
                            [FilePath -> [Content ()] -> Content ()
forall a. XmlContent a => a -> [Content ()] -> Content ()
mkElem "string" [Bool -> FilePath -> () -> Content ()
forall i. Bool -> FilePath -> i -> Content i
CString Bool
True ((a -> Char) -> [a] -> FilePath
forall a b. (a -> b) -> [a] -> [b]
map a -> Char
forall a. XmlContent a => a -> Char
xToChar [a]
xs) ()]]
                       _ -> [[a] -> [Content ()] -> Content ()
forall a. XmlContent a => a -> [Content ()] -> Content ()
mkElem [a]
xs ((a -> [Content ()]) -> [a] -> [Content ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap a -> [Content ()]
forall a. XmlContent a => a -> [Content ()]
toContents [a]
xs)]
                   where   (x :: a
x:_) = [a]
xs
    parseContents :: XMLParser [a]
parseContents = ([Content Posn] -> Result [Content Posn] [a]) -> XMLParser [a]
forall t a. ([t] -> Result [t] a) -> Parser t a
P (\x :: [Content Posn]
x ->
        case [Content Posn]
x of
            (CString _ s :: FilePath
s _:cs :: [Content Posn]
cs)
                   -> [Content Posn] -> [a] -> Result [Content Posn] [a]
forall z a. z -> a -> Result z a
Success [Content Posn]
cs ((Char -> a) -> FilePath -> [a]
forall a b. (a -> b) -> [a] -> [b]
map Char -> a
forall a. XmlContent a => Char -> a
xFromChar FilePath
s)
            (CElem (Elem (N "string") [] [CString _ s :: FilePath
s _]) _:cs :: [Content Posn]
cs)
                   -> [Content Posn] -> [a] -> Result [Content Posn] [a]
forall z a. z -> a -> Result z a
Success [Content Posn]
cs ((Char -> a) -> FilePath -> [a]
forall a b. (a -> b) -> [a] -> [b]
map Char -> a
forall a. XmlContent a => Char -> a
xFromChar FilePath
s)
            (CElem (Elem (N "string") [] []) _:cs :: [Content Posn]
cs)
                   -> [Content Posn] -> [a] -> Result [Content Posn] [a]
forall z a. z -> a -> Result z a
Success [Content Posn]
cs []
            (CElem (Elem (N e :: FilePath
e) [] xs :: [Content Posn]
xs) _:cs :: [Content Posn]
cs) | "list" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
e
                   -> [Content Posn] -> Result [Content Posn] [a]
forall a.
XmlContent a =>
[Content Posn] -> Result [Content Posn] [a]
scanElements [Content Posn]
xs
                   where
                  -- scanElements :: [Content] -> (Either String [a],[Content])
                     scanElements :: [Content Posn] -> Result [Content Posn] [a]
scanElements [] = [Content Posn] -> [a] -> Result [Content Posn] [a]
forall z a. z -> a -> Result z a
Success [Content Posn]
cs []
                     scanElements es :: [Content Posn]
es =
                        case Parser (Content Posn) a
-> [Content Posn] -> (Either FilePath a, [Content Posn])
forall t a. Parser t a -> [t] -> (Either FilePath a, [t])
runParser Parser (Content Posn) a
forall a. XmlContent a => XMLParser a
parseContents [Content Posn]
es of
                            (Left msg :: FilePath
msg, es' :: [Content Posn]
es') -> [Content Posn] -> FilePath -> Result [Content Posn] [a]
forall z a. z -> FilePath -> Result z a
Failure [Content Posn]
es' FilePath
msg
                            (Right y :: a
y, es' :: [Content Posn]
es') ->
                                case [Content Posn] -> Result [Content Posn] [a]
scanElements [Content Posn]
es' of
                                    Failure ds :: [Content Posn]
ds msg :: FilePath
msg -> [Content Posn] -> FilePath -> Result [Content Posn] [a]
forall z a. z -> FilePath -> Result z a
Failure [Content Posn]
ds FilePath
msg
                                    Success ds :: [Content Posn]
ds ys :: [a]
ys  -> [Content Posn] -> [a] -> Result [Content Posn] [a]
forall z a. z -> a -> Result z a
Success [Content Posn]
ds (a
ya -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ys)
            (CElem (Elem e :: QName
e _ _) pos :: Posn
pos: cs :: [Content Posn]
cs)
                   -> [Content Posn] -> FilePath -> Result [Content Posn] [a]
forall z a. z -> FilePath -> Result z a
Failure [Content Posn]
cs ("Expected a <list-...>, but found a <"
                                  FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++QName -> FilePath
printableName QName
e
                                  FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++"> at\n"FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++Posn -> FilePath
forall a. Show a => a -> FilePath
show Posn
pos)
            (CRef r :: Reference
r pos :: Posn
pos: cs :: [Content Posn]
cs)
                   -> [Content Posn] -> FilePath -> Result [Content Posn] [a]
forall z a. z -> FilePath -> Result z a
Failure [Content Posn]
cs ("Expected a <list-...>, but found a ref "
                                  FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++Reference -> FilePath
forall a. Verbatim a => a -> FilePath
verbatim Reference
rFilePath -> ShowS
forall a. [a] -> [a] -> [a]
++" at\n"FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Posn -> FilePath
forall a. Show a => a -> FilePath
show Posn
pos)
            (_:cs :: [Content Posn]
cs) -> ((\ (P p :: [Content Posn] -> Result [Content Posn] [a]
p)-> [Content Posn] -> Result [Content Posn] [a]
p) XMLParser [a]
forall a. XmlContent a => XMLParser a
parseContents) [Content Posn]
cs  -- skip comments etc.
            []     -> [Content Posn] -> FilePath -> Result [Content Posn] [a]
forall z a. z -> FilePath -> Result z a
Failure [] "Ran out of input XML whilst secondary parsing"
        )

instance XmlContent () where
    toContents :: () -> [Content ()]
toContents ()  = [Element () -> () -> Content ()
forall i. Element i -> i -> Content i
CElem (QName -> [Attribute] -> [Content ()] -> Element ()
forall i. QName -> [Attribute] -> [Content i] -> Element i
Elem (FilePath -> QName
N "unit") [] []) ()]
    parseContents :: XMLParser ()
parseContents = do { [FilePath] -> XMLParser (Element Posn)
element ["unit"]; () -> XMLParser ()
forall (m :: * -> *) a. Monad m => a -> m a
return () }


instance (XmlContent a) => XmlContent (Maybe a) where
    toContents :: Maybe a -> [Content ()]
toContents m :: Maybe a
m   = [Maybe a -> [Content ()] -> Content ()
forall a. XmlContent a => a -> [Content ()] -> Content ()
mkElem Maybe a
m ([Content ()] -> (a -> [Content ()]) -> Maybe a -> [Content ()]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] a -> [Content ()]
forall a. XmlContent a => a -> [Content ()]
toContents Maybe a
m)]
    parseContents :: XMLParser (Maybe a)
parseContents = do
        { Element Posn
e <- (FilePath -> FilePath -> Bool)
-> [FilePath] -> XMLParser (Element Posn)
elementWith ((FilePath -> FilePath -> Bool) -> FilePath -> FilePath -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf) ["maybe"]
        ; case Element Posn
e of (Elem _ [] []) -> Maybe a -> XMLParser (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
                    (Elem _ [] _)  -> (a -> Maybe a) -> Parser (Content Posn) a -> XMLParser (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just (Element Posn -> Parser (Content Posn) a -> Parser (Content Posn) a
forall a. Element Posn -> XMLParser a -> XMLParser a
interior Element Posn
e Parser (Content Posn) a
forall a. XmlContent a => XMLParser a
parseContents)
        }

instance (XmlContent a, XmlContent b) => XmlContent (Either a b) where
    toContents :: Either a b -> [Content ()]
toContents v :: Either a b
v@(Left aa :: a
aa) =
        [FilePath -> [Content ()] -> Content ()
mkElemC (Int -> HType -> FilePath
showConstr 0 (Either a b -> HType
forall a. HTypeable a => a -> HType
toHType Either a b
v)) (a -> [Content ()]
forall a. XmlContent a => a -> [Content ()]
toContents a
aa)]
    toContents v :: Either a b
v@(Right ab :: b
ab) =
        [FilePath -> [Content ()] -> Content ()
mkElemC (Int -> HType -> FilePath
showConstr 1 (Either a b -> HType
forall a. HTypeable a => a -> HType
toHType Either a b
v)) (b -> [Content ()]
forall a. XmlContent a => a -> [Content ()]
toContents b
ab)]
    parseContents :: XMLParser (Either a b)
parseContents =
        ((FilePath -> FilePath -> Bool)
-> FilePath -> XMLParser (Either a b) -> XMLParser (Either a b)
forall a.
(FilePath -> FilePath -> Bool)
-> FilePath -> XMLParser a -> XMLParser a
inElementWith ((FilePath -> FilePath -> Bool) -> FilePath -> FilePath -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf) "Left"  (XMLParser (Either a b) -> XMLParser (Either a b))
-> XMLParser (Either a b) -> XMLParser (Either a b)
forall a b. (a -> b) -> a -> b
$ (a -> Either a b)
-> Parser (Content Posn) a -> XMLParser (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either a b
forall a b. a -> Either a b
Left  Parser (Content Posn) a
forall a. XmlContent a => XMLParser a
parseContents)
          XMLParser (Either a b)
-> XMLParser (Either a b) -> XMLParser (Either a b)
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
        ((FilePath -> FilePath -> Bool)
-> FilePath -> XMLParser (Either a b) -> XMLParser (Either a b)
forall a.
(FilePath -> FilePath -> Bool)
-> FilePath -> XMLParser a -> XMLParser a
inElementWith ((FilePath -> FilePath -> Bool) -> FilePath -> FilePath -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf) "Right" (XMLParser (Either a b) -> XMLParser (Either a b))
-> XMLParser (Either a b) -> XMLParser (Either a b)
forall a b. (a -> b) -> a -> b
$ (b -> Either a b)
-> Parser (Content Posn) b -> XMLParser (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> Either a b
forall a b. b -> Either a b
Right Parser (Content Posn) b
forall a. XmlContent a => XMLParser a
parseContents)

--    do{ e@(Elem t [] _) <- element ["Left","Right"]
--      ; case t of
--          _ | "Left"  `isPrefixOf` t -> fmap Left  (interior e parseContents)
--            | "Right" `isPrefixOf` t -> fmap Right (interior e parseContents)
--      }

------------------------------------------------------------------------