Advertisement
edv

gxl_dtd

edv
Nov 15th, 2011
153
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
Haskell 25.56 KB | None | 0 0
  1. module GXL where
  2.  
  3. import Text.XML.HaXml.XmlContent
  4. import Text.XML.HaXml.OneOfN
  5. import qualified Text.XML.HaXml.Types as T
  6.  
  7.  
  8. {-Type decls-}
  9.  
  10. data Gxl = Gxl Gxl_Attrs [Graph]
  11.          deriving (Eq,Show)
  12. data Gxl_Attrs = Gxl_Attrs
  13.     { gxlXmlns'xlink :: (Defaultable String)
  14.    } deriving (Eq,Show)
  15. data Type = Type
  16.    { typeXlink'type :: (Defaultable Type_xlink'type)
  17.    , typeXlink'href :: String
  18.     } deriving (Eq,Show)
  19. data Type_xlink'type = Type_xlink'type_simple
  20.                      deriving (Eq,Show)
  21. data Graph = Graph Graph_Attrs (Maybe Type) [Attr]
  22.                    [(OneOf3 Node Edge Rel)]
  23.            deriving (Eq,Show)
  24. data Graph_Attrs = Graph_Attrs
  25.     { graphId :: String
  26.     , graphRole :: (Maybe String)
  27.     , graphEdgeids :: (Defaultable Graph_edgeids)
  28.     , graphHypergraph :: (Defaultable Graph_hypergraph)
  29.     , graphEdgemode :: (Defaultable Graph_edgemode)
  30.     } deriving (Eq,Show)
  31. data Graph_edgeids = Graph_edgeids_true  |  Graph_edgeids_false
  32.                    deriving (Eq,Show)
  33. data Graph_hypergraph = Graph_hypergraph_true  |
  34.                         Graph_hypergraph_false
  35.                       deriving (Eq,Show)
  36. data Graph_edgemode = Graph_edgemode_directed  |
  37.                       Graph_edgemode_undirected  |  Graph_edgemode_defaultdirected  |
  38.                       Graph_edgemode_defaultundirected
  39.                     deriving (Eq,Show)
  40. data Node = Node Node_Attrs (Maybe Type) [Attr] [Graph]
  41.           deriving (Eq,Show)
  42. data Node_Attrs = Node_Attrs
  43.     { nodeId :: String
  44.     } deriving (Eq,Show)
  45. data Edge = Edge Edge_Attrs (Maybe Type) [Attr] [Graph]
  46.           deriving (Eq,Show)
  47. data Edge_Attrs = Edge_Attrs
  48.     { edgeId :: (Maybe String)
  49.     , edgeFrom :: String
  50.     , edgeTo :: String
  51.     , edgeFromorder :: (Maybe String)
  52.     , edgeToorder :: (Maybe String)
  53.     , edgeIsdirected :: (Maybe Edge_isdirected)
  54.     } deriving (Eq,Show)
  55. data Edge_isdirected = Edge_isdirected_true  |
  56.                        Edge_isdirected_false
  57.                      deriving (Eq,Show)
  58. data Rel = Rel Rel_Attrs (Maybe Type) [Attr] [Graph] [Relend]
  59.          deriving (Eq,Show)
  60. data Rel_Attrs = Rel_Attrs
  61.     { relId :: (Maybe String)
  62.     , relIsdirected :: (Maybe Rel_isdirected)
  63.     } deriving (Eq,Show)
  64. data Rel_isdirected = Rel_isdirected_true  |  Rel_isdirected_false
  65.                     deriving (Eq,Show)
  66. data Relend = Relend Relend_Attrs [Attr]
  67.             deriving (Eq,Show)
  68. data Relend_Attrs = Relend_Attrs
  69.     { relendTarget :: String
  70.     , relendRole :: (Maybe String)
  71.     , relendDirection :: (Maybe Relend_direction)
  72.     , relendStartorder :: (Maybe String)
  73.     , relendEndorder :: (Maybe String)
  74.     } deriving (Eq,Show)
  75. data Relend_direction = Relend_direction_in  |
  76.                         Relend_direction_out  |  Relend_direction_none
  77.                       deriving (Eq,Show)
  78. data Attr = Attr Attr_Attrs [Attr]
  79.                  (OneOf10 Locator ABool AInt AFloat AString AEnum Seq Set Bag Tup)
  80.           deriving (Eq,Show)
  81. data Attr_Attrs = Attr_Attrs
  82.     { attrId :: (Maybe String)
  83.     , attrName :: String
  84.     , attrKind :: (Maybe String)
  85.     } deriving (Eq,Show)
  86. data Locator = Locator
  87.     { locatorXlink'type :: (Defaultable Locator_xlink'type)
  88.     , locatorXlink'href :: String
  89.    } deriving (Eq,Show)
  90. data Locator_xlink'type = Locator_xlink'type_simple
  91.                        deriving (Eq,Show)
  92. newtype ABool = ABool String        deriving (Eq,Show)
  93. newtype AInt = AInt String      deriving (Eq,Show)
  94. newtype AFloat = AFloat String      deriving (Eq,Show)
  95. newtype AString = AString String        deriving (Eq,Show)
  96. newtype AEnum = AEnum String        deriving (Eq,Show)
  97. newtype Seq = Seq [Seq_]        deriving (Eq,Show)
  98. data Seq_ = Seq_Locator Locator
  99.          | Seq_ABool ABool
  100.          | Seq_AInt AInt
  101.          | Seq_AFloat AFloat
  102.          | Seq_AString AString
  103.          | Seq_AEnum AEnum
  104.          | Seq_Seq Seq
  105.          | Seq_Set Set
  106.          | Seq_Bag Bag
  107.          | Seq_Tup Tup
  108.          deriving (Eq,Show)
  109. newtype Set = Set [Set_]        deriving (Eq,Show)
  110. data Set_ = Set_Locator Locator
  111.          | Set_ABool ABool
  112.          | Set_AInt AInt
  113.          | Set_AFloat AFloat
  114.          | Set_AString AString
  115.          | Set_AEnum AEnum
  116.          | Set_Seq Seq
  117.          | Set_Set Set
  118.          | Set_Bag Bag
  119.          | Set_Tup Tup
  120.          deriving (Eq,Show)
  121. newtype Bag = Bag [Bag_]        deriving (Eq,Show)
  122. data Bag_ = Bag_Locator Locator
  123.          | Bag_ABool ABool
  124.          | Bag_AInt AInt
  125.          | Bag_AFloat AFloat
  126.          | Bag_AString AString
  127.          | Bag_AEnum AEnum
  128.          | Bag_Seq Seq
  129.          | Bag_Set Set
  130.          | Bag_Bag Bag
  131.          | Bag_Tup Tup
  132.          deriving (Eq,Show)
  133. newtype Tup = Tup [Tup_]        deriving (Eq,Show)
  134. data Tup_ = Tup_Locator Locator
  135.          | Tup_ABool ABool
  136.          | Tup_AInt AInt
  137.          | Tup_AFloat AFloat
  138.          | Tup_AString AString
  139.          | Tup_AEnum AEnum
  140.          | Tup_Seq Seq
  141.          | Tup_Set Set
  142.          | Tup_Bag Bag
  143.          | Tup_Tup Tup
  144.          deriving (Eq,Show)
  145.  
  146.  
  147. {-Instance decls-}
  148.  
  149. instance HTypeable Gxl where
  150.    toHType x = Defined "gxl" [] []
  151. instance XmlContent Gxl where
  152.    toContents (Gxl as a) =
  153.        [CElem (Elem (T.N "gxl") (toAttrs as) (concatMap toContents a)) ()]
  154.    parseContents = do
  155.        { e@(Elem _ as _) <- element ["gxl"]
  156.        ; interior e $ return (Gxl (fromAttrs as))
  157.                       `apply` many parseContents
  158.        } `adjustErr` ("in <gxl>, "++)
  159. instance XmlAttributes Gxl_Attrs where
  160.    fromAttrs as =
  161.        Gxl_Attrs
  162.          { gxlXmlns'xlink = defaultA fromAttrToStr "http://www.w3.org/1999/xlink" "xmlns:xlink" as
  163.           }
  164.     toAttrs v = catMaybes
  165.         [ defaultToAttr toAttrFrStr "xmlns:xlink" (gxlXmlns'xlink v)
  166.        ]
  167.  
  168. instance HTypeable Type where
  169.    toHType x = Defined "type" [] []
  170. instance XmlContent Type where
  171.    toContents as =
  172.        [CElem (Elem (T.N "type") (toAttrs as) []) ()]
  173.    parseContents = do
  174.        { (Elem _ as []) <- element ["type"]
  175.        ; return (fromAttrs as)
  176.        } `adjustErr` ("in <type>, "++)
  177. instance XmlAttributes Type where
  178.    fromAttrs as =
  179.        Type
  180.          { typeXlink'type = defaultA fromAttrToTyp Type_xlink'type_simple "xlink:type" as
  181.          , typeXlink'href = definiteA fromAttrToStr "type" "xlink:href" as
  182.           }
  183.     toAttrs v = catMaybes
  184.         [ defaultToAttr toAttrFrTyp "xlink:type" (typeXlink'type v)
  185.        , toAttrFrStr "xlink:href" (typeXlink'href v)
  186.         ]
  187.  
  188. instance XmlAttrType Type_xlink'type where
  189.    fromAttrToTyp n (n',v)
  190.         | n==(show n')     = translate (attr2str v)
  191.        | otherwise = Nothing
  192.      where translate "simple" = Just Type_xlink'type_simple
  193.             translate _ = Nothing
  194.     toAttrFrTyp n Type_xlink'type_simple = Just (T.N n, str2attr "simple")
  195.  
  196. instance HTypeable Graph where
  197.    toHType x = Defined "graph" [] []
  198. instance XmlContent Graph where
  199.    toContents (Graph as a b c) =
  200.        [CElem (Elem (T.N "graph") (toAttrs as) (maybe [] toContents a ++
  201.                                           concatMap toContents b ++ concatMap toContents c)) ()]
  202.    parseContents = do
  203.        { e@(Elem _ as _) <- element ["graph"]
  204.        ; interior e $ return (Graph (fromAttrs as))
  205.                       `apply` optional parseContents `apply` many parseContents
  206.                       `apply` many parseContents
  207.        } `adjustErr` ("in <graph>, "++)
  208. instance XmlAttributes Graph_Attrs where
  209.    fromAttrs as =
  210.        Graph_Attrs
  211.          { graphId = definiteA fromAttrToStr "graph" "id" as
  212.          , graphRole = possibleA fromAttrToStr "role" as
  213.          , graphEdgeids = defaultA fromAttrToTyp Graph_edgeids_false "edgeids" as
  214.          , graphHypergraph = defaultA fromAttrToTyp Graph_hypergraph_false "hypergraph" as
  215.          , graphEdgemode = defaultA fromAttrToTyp Graph_edgemode_directed "edgemode" as
  216.          }
  217.    toAttrs v = catMaybes
  218.        [ toAttrFrStr "id" (graphId v)
  219.        , maybeToAttr toAttrFrStr "role" (graphRole v)
  220.        , defaultToAttr toAttrFrTyp "edgeids" (graphEdgeids v)
  221.        , defaultToAttr toAttrFrTyp "hypergraph" (graphHypergraph v)
  222.        , defaultToAttr toAttrFrTyp "edgemode" (graphEdgemode v)
  223.        ]
  224.  
  225. instance XmlAttrType Graph_edgeids where
  226.    fromAttrToTyp n (n',v)
  227.         | n==(show n')     = translate (attr2str v)
  228.        | otherwise = Nothing
  229.      where translate "true" = Just Graph_edgeids_true
  230.            translate "false" = Just Graph_edgeids_false
  231.            translate _ = Nothing
  232.    toAttrFrTyp n Graph_edgeids_true = Just (T.N n, str2attr "true")
  233.    toAttrFrTyp n Graph_edgeids_false = Just (T.N n, str2attr "false")
  234.  
  235. instance XmlAttrType Graph_hypergraph where
  236.    fromAttrToTyp n (n',v)
  237.         | n==(show n')     = translate (attr2str v)
  238.        | otherwise = Nothing
  239.      where translate "true" = Just Graph_hypergraph_true
  240.            translate "false" = Just Graph_hypergraph_false
  241.            translate _ = Nothing
  242.    toAttrFrTyp n Graph_hypergraph_true = Just (T.N n, str2attr "true")
  243.    toAttrFrTyp n Graph_hypergraph_false = Just (T.N n, str2attr "false")
  244.  
  245. instance XmlAttrType Graph_edgemode where
  246.    fromAttrToTyp n (n',v)
  247.         | n==(show n')     = translate (attr2str v)
  248.        | otherwise = Nothing
  249.      where translate "directed" = Just Graph_edgemode_directed
  250.            translate "undirected" = Just Graph_edgemode_undirected
  251.            translate "defaultdirected" = Just Graph_edgemode_defaultdirected
  252.            translate "defaultundirected" = Just Graph_edgemode_defaultundirected
  253.            translate _ = Nothing
  254.    toAttrFrTyp n Graph_edgemode_directed = Just (T.N n, str2attr "directed")
  255.    toAttrFrTyp n Graph_edgemode_undirected = Just (T.N n, str2attr "undirected")
  256.    toAttrFrTyp n Graph_edgemode_defaultdirected = Just (T.N n, str2attr "defaultdirected")
  257.    toAttrFrTyp n Graph_edgemode_defaultundirected = Just (T.N n, str2attr "defaultundirected")
  258.  
  259. instance HTypeable Node where
  260.    toHType x = Defined "node" [] []
  261. instance XmlContent Node where
  262.    toContents (Node as a b c) =
  263.        [CElem (Elem (T.N "node") (toAttrs as) (maybe [] toContents a ++
  264.                                          concatMap toContents b ++ concatMap toContents c)) ()]
  265.    parseContents = do
  266.        { e@(Elem _ as _) <- element ["node"]
  267.        ; interior e $ return (Node (fromAttrs as))
  268.                       `apply` optional parseContents `apply` many parseContents
  269.                       `apply` many parseContents
  270.        } `adjustErr` ("in <node>, "++)
  271. instance XmlAttributes Node_Attrs where
  272.    fromAttrs as =
  273.        Node_Attrs
  274.          { nodeId = definiteA fromAttrToStr "node" "id" as
  275.          }
  276.    toAttrs v = catMaybes
  277.        [ toAttrFrStr "id" (nodeId v)
  278.        ]
  279.  
  280. instance HTypeable Edge where
  281.    toHType x = Defined "edge" [] []
  282. instance XmlContent Edge where
  283.    toContents (Edge as a b c) =
  284.        [CElem (Elem (T.N "edge") (toAttrs as) (maybe [] toContents a ++
  285.                                          concatMap toContents b ++ concatMap toContents c)) ()]
  286.    parseContents = do
  287.        { e@(Elem _ as _) <- element ["edge"]
  288.        ; interior e $ return (Edge (fromAttrs as))
  289.                       `apply` optional parseContents `apply` many parseContents
  290.                       `apply` many parseContents
  291.        } `adjustErr` ("in <edge>, "++)
  292. instance XmlAttributes Edge_Attrs where
  293.    fromAttrs as =
  294.        Edge_Attrs
  295.          { edgeId = possibleA fromAttrToStr "id" as
  296.          , edgeFrom = definiteA fromAttrToStr "edge" "from" as
  297.          , edgeTo = definiteA fromAttrToStr "edge" "to" as
  298.          , edgeFromorder = possibleA fromAttrToStr "fromorder" as
  299.          , edgeToorder = possibleA fromAttrToStr "toorder" as
  300.          , edgeIsdirected = possibleA fromAttrToTyp "isdirected" as
  301.          }
  302.    toAttrs v = catMaybes
  303.        [ maybeToAttr toAttrFrStr "id" (edgeId v)
  304.        , toAttrFrStr "from" (edgeFrom v)
  305.        , toAttrFrStr "to" (edgeTo v)
  306.        , maybeToAttr toAttrFrStr "fromorder" (edgeFromorder v)
  307.        , maybeToAttr toAttrFrStr "toorder" (edgeToorder v)
  308.        , maybeToAttr toAttrFrTyp "isdirected" (edgeIsdirected v)
  309.        ]
  310.  
  311. instance XmlAttrType Edge_isdirected where
  312.    fromAttrToTyp n (n',v)
  313.         | n==(show n')     = translate (attr2str v)
  314.        | otherwise = Nothing
  315.      where translate "true" = Just Edge_isdirected_true
  316.            translate "false" = Just Edge_isdirected_false
  317.            translate _ = Nothing
  318.    toAttrFrTyp n Edge_isdirected_true = Just (T.N n, str2attr "true")
  319.    toAttrFrTyp n Edge_isdirected_false = Just (T.N n, str2attr "false")
  320.  
  321. instance HTypeable Rel where
  322.    toHType x = Defined "rel" [] []
  323. instance XmlContent Rel where
  324.    toContents (Rel as a b c d) =
  325.        [CElem (Elem (T.N "rel") (toAttrs as) (maybe [] toContents a ++
  326.                                         concatMap toContents b ++ concatMap toContents c ++
  327.                                         concatMap toContents d)) ()]
  328.    parseContents = do
  329.        { e@(Elem _ as _) <- element ["rel"]
  330.        ; interior e $ return (Rel (fromAttrs as))
  331.                       `apply` optional parseContents `apply` many parseContents
  332.                       `apply` many parseContents `apply` many parseContents
  333.        } `adjustErr` ("in <rel>, "++)
  334. instance XmlAttributes Rel_Attrs where
  335.    fromAttrs as =
  336.        Rel_Attrs
  337.          { relId = possibleA fromAttrToStr "id" as
  338.          , relIsdirected = possibleA fromAttrToTyp "isdirected" as
  339.          }
  340.    toAttrs v = catMaybes
  341.        [ maybeToAttr toAttrFrStr "id" (relId v)
  342.        , maybeToAttr toAttrFrTyp "isdirected" (relIsdirected v)
  343.        ]
  344.  
  345. instance XmlAttrType Rel_isdirected where
  346.    fromAttrToTyp n (n',v)
  347.         | n==(show n')     = translate (attr2str v)
  348.        | otherwise = Nothing
  349.      where translate "true" = Just Rel_isdirected_true
  350.            translate "false" = Just Rel_isdirected_false
  351.            translate _ = Nothing
  352.    toAttrFrTyp n Rel_isdirected_true = Just (T.N n, str2attr "true")
  353.    toAttrFrTyp n Rel_isdirected_false = Just (T.N n, str2attr "false")
  354.  
  355. instance HTypeable Relend where
  356.    toHType x = Defined "relend" [] []
  357. instance XmlContent Relend where
  358.    toContents (Relend as a) =
  359.        [CElem (Elem (T.N "relend") (toAttrs as) (concatMap toContents a)) ()]
  360.    parseContents = do
  361.        { e@(Elem _ as _) <- element ["relend"]
  362.        ; interior e $ return (Relend (fromAttrs as))
  363.                       `apply` many parseContents
  364.        } `adjustErr` ("in <relend>, "++)
  365. instance XmlAttributes Relend_Attrs where
  366.    fromAttrs as =
  367.        Relend_Attrs
  368.          { relendTarget = definiteA fromAttrToStr "relend" "target" as
  369.          , relendRole = possibleA fromAttrToStr "role" as
  370.          , relendDirection = possibleA fromAttrToTyp "direction" as
  371.          , relendStartorder = possibleA fromAttrToStr "startorder" as
  372.          , relendEndorder = possibleA fromAttrToStr "endorder" as
  373.          }
  374.    toAttrs v = catMaybes
  375.        [ toAttrFrStr "target" (relendTarget v)
  376.        , maybeToAttr toAttrFrStr "role" (relendRole v)
  377.        , maybeToAttr toAttrFrTyp "direction" (relendDirection v)
  378.        , maybeToAttr toAttrFrStr "startorder" (relendStartorder v)
  379.        , maybeToAttr toAttrFrStr "endorder" (relendEndorder v)
  380.        ]
  381.  
  382. instance XmlAttrType Relend_direction where
  383.    fromAttrToTyp n (n',v)
  384.         | n==(show n')     = translate (attr2str v)
  385.        | otherwise = Nothing
  386.      where translate "in" = Just Relend_direction_in
  387.            translate "out" = Just Relend_direction_out
  388.            translate "none" = Just Relend_direction_none
  389.            translate _ = Nothing
  390.    toAttrFrTyp n Relend_direction_in = Just (T.N n, str2attr "in")
  391.    toAttrFrTyp n Relend_direction_out = Just (T.N n, str2attr "out")
  392.    toAttrFrTyp n Relend_direction_none = Just (T.N n, str2attr "none")
  393.  
  394. instance HTypeable Attr where
  395.    toHType x = Defined "attr" [] []
  396. instance XmlContent Attr where
  397.    toContents (Attr as a b) =
  398.        [CElem (Elem (T.N "attr") (toAttrs as) (concatMap toContents a ++
  399.                                          toContents b)) ()]
  400.    parseContents = do
  401.        { e@(Elem _ as _) <- element ["attr"]
  402.        ; interior e $ return (Attr (fromAttrs as))
  403.                       `apply` many parseContents `apply` parseContents
  404.        } `adjustErr` ("in <attr>, "++)
  405. instance XmlAttributes Attr_Attrs where
  406.    fromAttrs as =
  407.        Attr_Attrs
  408.          { attrId = possibleA fromAttrToStr "id" as
  409.          , attrName = definiteA fromAttrToStr "attr" "name" as
  410.          , attrKind = possibleA fromAttrToStr "kind" as
  411.          }
  412.    toAttrs v = catMaybes
  413.        [ maybeToAttr toAttrFrStr "id" (attrId v)
  414.        , toAttrFrStr "name" (attrName v)
  415.        , maybeToAttr toAttrFrStr "kind" (attrKind v)
  416.        ]
  417.  
  418. instance HTypeable Locator where
  419.    toHType x = Defined "locator" [] []
  420. instance XmlContent Locator where
  421.    toContents as =
  422.        [CElem (Elem (T.N "locator") (toAttrs as) []) ()]
  423.    parseContents = do
  424.        { (Elem _ as []) <- element ["locator"]
  425.        ; return (fromAttrs as)
  426.        } `adjustErr` ("in <locator>, "++)
  427. instance XmlAttributes Locator where
  428.    fromAttrs as =
  429.        Locator
  430.          { locatorXlink'type = defaultA fromAttrToTyp Locator_xlink'type_simple "xlink:type" as
  431.          , locatorXlink'href = definiteA fromAttrToStr "locator" "xlink:href" as
  432.           }
  433.     toAttrs v = catMaybes
  434.         [ defaultToAttr toAttrFrTyp "xlink:type" (locatorXlink'type v)
  435.        , toAttrFrStr "xlink:href" (locatorXlink'href v)
  436.         ]
  437.  
  438. instance XmlAttrType Locator_xlink'type where
  439.    fromAttrToTyp n (n',v)
  440.         | n==(show n')     = translate (attr2str v)
  441.        | otherwise = Nothing
  442.      where translate "simple" = Just Locator_xlink'type_simple
  443.             translate _ = Nothing
  444.     toAttrFrTyp n Locator_xlink'type_simple = Just (T.N n, str2attr "simple")
  445.  
  446. instance HTypeable ABool where
  447.    toHType x = Defined "bool" [] []
  448. instance XmlContent ABool where
  449.    toContents (ABool a) =
  450.        [CElem (Elem (T.N "bool") [] (toText a)) ()]
  451.    parseContents = do
  452.        { e@(Elem _ [] _) <- element ["bool"]
  453.        ; interior e $ return (ABool) `apply` (text `onFail` return "")
  454.        } `adjustErr` ("in <bool>, "++)
  455.  
  456. instance HTypeable AInt where
  457.    toHType x = Defined "int" [] []
  458. instance XmlContent AInt where
  459.    toContents (AInt a) =
  460.        [CElem (Elem (T.N "int") [] (toText a)) ()]
  461.    parseContents = do
  462.        { e@(Elem _ [] _) <- element ["int"]
  463.        ; interior e $ return (AInt) `apply` (text `onFail` return "")
  464.        } `adjustErr` ("in <int>, "++)
  465.  
  466. instance HTypeable AFloat where
  467.    toHType x = Defined "float" [] []
  468. instance XmlContent AFloat where
  469.    toContents (AFloat a) =
  470.        [CElem (Elem (T.N "float") [] (toText a)) ()]
  471.    parseContents = do
  472.        { e@(Elem _ [] _) <- element ["float"]
  473.        ; interior e $ return (AFloat) `apply` (text `onFail` return "")
  474.        } `adjustErr` ("in <float>, "++)
  475.  
  476. instance HTypeable AString where
  477.    toHType x = Defined "string" [] []
  478. instance XmlContent AString where
  479.    toContents (AString a) =
  480.        [CElem (Elem (T.N "string") [] (toText a)) ()]
  481.    parseContents = do
  482.        { e@(Elem _ [] _) <- element ["string"]
  483.        ; interior e $ return (AString) `apply` (text `onFail` return "")
  484.        } `adjustErr` ("in <string>, "++)
  485.  
  486. instance HTypeable AEnum where
  487.    toHType x = Defined "enum" [] []
  488. instance XmlContent AEnum where
  489.    toContents (AEnum a) =
  490.        [CElem (Elem (T.N "enum") [] (toText a)) ()]
  491.    parseContents = do
  492.        { e@(Elem _ [] _) <- element ["enum"]
  493.        ; interior e $ return (AEnum) `apply` (text `onFail` return "")
  494.        } `adjustErr` ("in <enum>, "++)
  495.  
  496. instance HTypeable Seq where
  497.    toHType x = Defined "seq" [] []
  498. instance XmlContent Seq where
  499.    toContents (Seq a) =
  500.        [CElem (Elem (T.N "seq") [] (concatMap toContents a)) ()]
  501.    parseContents = do
  502.        { e@(Elem _ [] _) <- element ["seq"]
  503.        ; interior e $ return (Seq) `apply` many parseContents
  504.        } `adjustErr` ("in <seq>, "++)
  505.  
  506. instance HTypeable Seq_ where
  507.    toHType x = Defined "seq" [] []
  508. instance XmlContent Seq_ where
  509.    toContents (Seq_Locator a) = toContents a
  510.    toContents (Seq_ABool a) = toContents a
  511.    toContents (Seq_AInt a) = toContents a
  512.    toContents (Seq_AFloat a) = toContents a
  513.    toContents (Seq_AString a) = toContents a
  514.    toContents (Seq_AEnum a) = toContents a
  515.    toContents (Seq_Seq a) = toContents a
  516.    toContents (Seq_Set a) = toContents a
  517.    toContents (Seq_Bag a) = toContents a
  518.    toContents (Seq_Tup a) = toContents a
  519.    parseContents = oneOf
  520.        [ return (Seq_Locator) `apply` parseContents
  521.        , return (Seq_ABool) `apply` parseContents
  522.        , return (Seq_AInt) `apply` parseContents
  523.        , return (Seq_AFloat) `apply` parseContents
  524.        , return (Seq_AString) `apply` parseContents
  525.        , return (Seq_AEnum) `apply` parseContents
  526.        , return (Seq_Seq) `apply` parseContents
  527.        , return (Seq_Set) `apply` parseContents
  528.        , return (Seq_Bag) `apply` parseContents
  529.        , return (Seq_Tup) `apply` parseContents
  530.        ] `adjustErr` ("in <seq>, "++)
  531.  
  532. instance HTypeable Set where
  533.    toHType x = Defined "set" [] []
  534. instance XmlContent Set where
  535.    toContents (Set a) =
  536.        [CElem (Elem (T.N "set") [] (concatMap toContents a)) ()]
  537.    parseContents = do
  538.        { e@(Elem _ [] _) <- element ["set"]
  539.        ; interior e $ return (Set) `apply` many parseContents
  540.        } `adjustErr` ("in <set>, "++)
  541.  
  542. instance HTypeable Set_ where
  543.    toHType x = Defined "set" [] []
  544. instance XmlContent Set_ where
  545.    toContents (Set_Locator a) = toContents a
  546.    toContents (Set_ABool a) = toContents a
  547.    toContents (Set_AInt a) = toContents a
  548.    toContents (Set_AFloat a) = toContents a
  549.    toContents (Set_AString a) = toContents a
  550.    toContents (Set_AEnum a) = toContents a
  551.    toContents (Set_Seq a) = toContents a
  552.    toContents (Set_Set a) = toContents a
  553.    toContents (Set_Bag a) = toContents a
  554.    toContents (Set_Tup a) = toContents a
  555.    parseContents = oneOf
  556.        [ return (Set_Locator) `apply` parseContents
  557.        , return (Set_ABool) `apply` parseContents
  558.        , return (Set_AInt) `apply` parseContents
  559.        , return (Set_AFloat) `apply` parseContents
  560.        , return (Set_AString) `apply` parseContents
  561.        , return (Set_AEnum) `apply` parseContents
  562.        , return (Set_Seq) `apply` parseContents
  563.        , return (Set_Set) `apply` parseContents
  564.        , return (Set_Bag) `apply` parseContents
  565.        , return (Set_Tup) `apply` parseContents
  566.        ] `adjustErr` ("in <set>, "++)
  567.  
  568. instance HTypeable Bag where
  569.    toHType x = Defined "bag" [] []
  570. instance XmlContent Bag where
  571.    toContents (Bag a) =
  572.        [CElem (Elem (T.N "bag") [] (concatMap toContents a)) ()]
  573.    parseContents = do
  574.        { e@(Elem _ [] _) <- element ["bag"]
  575.        ; interior e $ return (Bag) `apply` many parseContents
  576.        } `adjustErr` ("in <bag>, "++)
  577.  
  578. instance HTypeable Bag_ where
  579.    toHType x = Defined "bag" [] []
  580. instance XmlContent Bag_ where
  581.    toContents (Bag_Locator a) = toContents a
  582.    toContents (Bag_ABool a) = toContents a
  583.    toContents (Bag_AInt a) = toContents a
  584.    toContents (Bag_AFloat a) = toContents a
  585.    toContents (Bag_AString a) = toContents a
  586.    toContents (Bag_AEnum a) = toContents a
  587.    toContents (Bag_Seq a) = toContents a
  588.    toContents (Bag_Set a) = toContents a
  589.    toContents (Bag_Bag a) = toContents a
  590.    toContents (Bag_Tup a) = toContents a
  591.    parseContents = oneOf
  592.        [ return (Bag_Locator) `apply` parseContents
  593.        , return (Bag_ABool) `apply` parseContents
  594.        , return (Bag_AInt) `apply` parseContents
  595.        , return (Bag_AFloat) `apply` parseContents
  596.        , return (Bag_AString) `apply` parseContents
  597.        , return (Bag_AEnum) `apply` parseContents
  598.        , return (Bag_Seq) `apply` parseContents
  599.        , return (Bag_Set) `apply` parseContents
  600.        , return (Bag_Bag) `apply` parseContents
  601.        , return (Bag_Tup) `apply` parseContents
  602.        ] `adjustErr` ("in <bag>, "++)
  603.  
  604. instance HTypeable Tup where
  605.    toHType x = Defined "tup" [] []
  606. instance XmlContent Tup where
  607.    toContents (Tup a) =
  608.        [CElem (Elem (T.N "tup") [] (concatMap toContents a)) ()]
  609.    parseContents = do
  610.        { e@(Elem _ [] _) <- element ["tup"]
  611.        ; interior e $ return (Tup) `apply` many parseContents
  612.        } `adjustErr` ("in <tup>, "++)
  613.  
  614. instance HTypeable Tup_ where
  615.    toHType x = Defined "tup" [] []
  616. instance XmlContent Tup_ where
  617.    toContents (Tup_Locator a) = toContents a
  618.    toContents (Tup_ABool a) = toContents a
  619.    toContents (Tup_AInt a) = toContents a
  620.    toContents (Tup_AFloat a) = toContents a
  621.    toContents (Tup_AString a) = toContents a
  622.    toContents (Tup_AEnum a) = toContents a
  623.    toContents (Tup_Seq a) = toContents a
  624.    toContents (Tup_Set a) = toContents a
  625.    toContents (Tup_Bag a) = toContents a
  626.    toContents (Tup_Tup a) = toContents a
  627.    parseContents = oneOf
  628.        [ return (Tup_Locator) `apply` parseContents
  629.        , return (Tup_ABool) `apply` parseContents
  630.        , return (Tup_AInt) `apply` parseContents
  631.        , return (Tup_AFloat) `apply` parseContents
  632.        , return (Tup_AString) `apply` parseContents
  633.        , return (Tup_AEnum) `apply` parseContents
  634.        , return (Tup_Seq) `apply` parseContents
  635.        , return (Tup_Set) `apply` parseContents
  636.        , return (Tup_Bag) `apply` parseContents
  637.        , return (Tup_Tup) `apply` parseContents
  638.        ] `adjustErr` ("in <tup>, "++)
  639.  
  640.  
  641.  
  642. {-Done-}
  643.  
  644.  
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement