darcs - INblobs

1 module DocumentFile where

4 import Document as Doc

5 import Palette

6 import Shape

7 import Ports

8 import INRule

9 import InfoKind

10 import NetworkFile

12 import Text.XML.HaXml.Types

13 import Text.XML.HaXml.Posn (noPos)

14 import Text.XML.HaXml.Parse

15 import Text.XML.HaXml.XmlContent as XML

16 import Text.PrettyPrint.HughesPJ

17 import qualified Text.XML.HaXml.Pretty as Pretty

20 -- | Print the document data structure to an XML text

21 toString :: (InfoKind n g, InfoKind e g, XmlContent g) =>

22 Doc.Document g n e -> String

23 toString doc = render . Pretty.document $

24 Document (Prolog Nothing [] Nothing []) emptyST (f (toContents doc)) []

25 where

26 f [CElem e _] = e

27 f _ = error "bad" -- shouldn't happen

29 -- | Parses a string to the document data structure

30 -- Returns either an error message (Left) or the document,

31 -- a list of warnings (Right) and a boolean indicating whether

32 -- the file was an old INBlobs file

33 fromString :: (InfoKind n g, InfoKind e g, XmlContent g) =>

34 String -> Either String (Doc.Document g n e, [String], Bool)

35 fromString xml =

36 case xmlParse' "input file" xml of

37 Left err -> Left err -- lexical or initial (generic) parse error

38 Right (Document _ _ e _) ->

39 case runParser parseContents [CElem e noPos] of

40 (Left err, _) -> Left err -- secondary (typeful) parse error

41 (Right v, _) -> Right (v,[],False)

45 instance HTypeable (Doc.Document g n e) where

46 toHType _ = Defined "Document" [] [Constr "Document" [] []]

47 instance (InfoKind n g, InfoKind e g, XmlContent g) =>

48 XmlContent (Doc.Document g n e) where

49 toContents document =

50 [CElem (Elem "Document" []

51 $ (toContents $ getNetwork document)

52 ++ (toContents $ getPalette document)

53 ++ [ makeTag "Rules" (concatMap toContents

54 $ getRules document)

55 ]) () ]

56 parseContents = do

57 { inElement "Document" $ do

58 { net <- parseContents

59 ; pal <- parseContents

60 ; rus <- inElement "Rules" $ many1 parseContents

61 ; return ( setRules rus

62 . setPalette pal

63 . setNetwork net

64 $ Doc.empty undefined undefined undefined)

65 }

66 }

68 instance HTypeable a => HTypeable (Palette a) where

69 toHType p = Defined "Palette" [toHType a] [Constr "Palette" [] []]

70 where (Palette ((_,(_,_,Just a)):_)) = p

71 instance XmlContent a => XmlContent (Palette a) where

72 toContents (Palette shapes) =

73 [ mkElemC "Palette" (map aux shapes) ]

74 where

75 -- aux :: (ShapeName,(Shape,Ports,Maybe a)) -> Content ()

76 aux (name,(shape,pPort:ports, info)) =

77 CElem (Elem "Symbol" []

78 [ escapeString "ShapeName" name

79 , makeTag "Shape" $ toContents shape

80 , makeTag "Ports"

81 [ makeTag "Principals" [auxPort pPort]

82 , makeTag "Auxiliaries" $ map auxPort ports]

83 , makeTag "Info" $ toContents info

84 ]) ()

85 auxPort :: Port -> Content ()

86 auxPort = makeTag "Port" . toContents

87 parseContents = do

88 { inElement "Palette" $ fmap Palette (many1 parseSymbol) }

90 parseSymbol :: (XmlContent a) => XMLParser (ShapeName,(Shape,Ports,Maybe a))

91 parseSymbol = do

92 { inElement "Symbol" $ do

93 { name <- inElement "ShapeName" $ XML.text

94 ; shape <- inElement "Shape" $ parseContents

95 ; ([pP],aPs) <- inElement "Ports" $ parsePorts

96 ; info <- inElement "Info" $ parseContents

97 ; return (name,(shape,pP:aPs,info)) } }

99 parsePorts :: XMLParser (Ports,Ports)

100 parsePorts =

101 do

102 pPorts <- inElement "Principals" $ many1 parsePort -- principal ports

103 aPorts <- inElement "Auxiliaries" $ many parsePort -- auxiliary ports

104 return (pPorts, aPorts)

105

106 parsePort :: XMLParser Port

107 parsePort = inElement "Port" $ parseContents

108

109 instance HTypeable (INRule g n e) where

110 toHType _ = Defined "INRule" [] [Constr "INRule" [] []]

111 instance (InfoKind n g, InfoKind e g, XmlContent g) =>

112 XmlContent (INRule g n e) where

113 toContents rule =

114 [CElem (Elem "INRule" []

115 [ escapeString "Name" (getName rule)

116 , makeTag "LHS" (toContents $ getLHS rule)

117 , makeTag "RHS" (toContents $ getRHS rule)

118 , makeTag "Mapping" (map toContentsMappingElement

119 $ getMapping rule)

120 ]) () ]

121 where

122 toContentsMappingElement :: MappingElement -> Content ()

123 toContentsMappingElement (nNr1,nNr2) =

124 CElem (Elem "MappingElement"

125 [ mkAttr "lhs" (show nNr1)

126 , mkAttr "rhs" (show nNr2)

127 ] []) ()

128 parseContents = do

129 { inElement "INRule" $ do

130 { nam <- inElement "Name" $ XML.text

131 ; lhs <- inElement "LHS" $ parseContents

132 ; rhs <- inElement "RHS" $ parseContents

133 ; maa <- inElement "Mapping" $ many parseMappingElement

134 ; return ( INRule.construct nam lhs rhs maa)

135 }

136 }

137

138 parseMappingElement :: XMLParser MappingElement

139 parseMappingElement = do

140 { (p, e@(Elem _ [("lhs",nNr1),("rhs",nNr2)] [])) <- posnElement ["MappingElement"]

141 ; nNr1' <- attr2value nNr1

142 ; nNr2' <- attr2value nNr2

143 ; return (nNr1', nNr2')

144 }

145