INblobs-0.1.1: src/DocumentFile.hs

module DocumentFile where


import Document as Doc
import Palette
import Shape
import Ports
import INRule
import InfoKind
import NetworkFile

import Text.XML.HaXml.Types
import Text.XML.HaXml.Posn (noPos)
import Text.XML.HaXml.Parse
import Text.XML.HaXml.XmlContent as XML
import Text.PrettyPrint.HughesPJ
import qualified Text.XML.HaXml.Pretty as Pretty


-- | Print the document data structure to an XML text
toString :: (InfoKind n g, InfoKind e g, XmlContent g) =>
            Doc.Document g n e -> String
toString doc = render . Pretty.document $
    Document (Prolog Nothing [] Nothing []) emptyST (f (toContents doc)) []
  where
    f [CElem e _] = e
    f _ = error "bad"	-- shouldn't happen

-- | Parses a string to the document data structure
--   Returns either an error message (Left) or the document,
--   a list of warnings (Right) and a boolean indicating whether
--   the file was an old INBlobs file
fromString :: (InfoKind n g, InfoKind e g, XmlContent g) =>
              String -> Either String (Doc.Document g n e, [String], Bool)
fromString xml =
    case xmlParse' "input file" xml of
        Left err -> Left err -- lexical or initial (generic) parse error
        Right (Document _ _ e _) ->
            case runParser parseContents [CElem e noPos] of
                (Left err, _) -> Left err  -- secondary (typeful) parse error
                (Right v, _)  -> Right (v,[],False)



instance HTypeable (Doc.Document g n e) where
    toHType _ = Defined "Document" [] [Constr "Document" [] []]
instance (InfoKind n g, InfoKind e g, XmlContent g) =>
         XmlContent (Doc.Document g n e) where
    toContents document = 
        [CElem (Elem "Document" []
                   $  (toContents $ getNetwork document)
                   ++ (toContents $ getPalette document)
                   ++ [ makeTag "Rules" (concatMap toContents
                                                      $ getRules document)
                   ]) () ]
    parseContents = do
        { inElement "Document" $ do
              { net <- parseContents
              ; pal <- parseContents
              ; rus <- inElement "Rules"   $ many1 parseContents
              ; return ( setRules   rus
                       . setPalette pal
                       . setNetwork net
                       $ Doc.empty undefined undefined undefined)
              }
        }

instance HTypeable a => HTypeable (Palette a) where
    toHType p = Defined "Palette" [toHType a] [Constr "Palette" [] []]
              where (Palette ((_,(_,_,Just a)):_)) = p
instance XmlContent a => XmlContent (Palette a) where
    toContents (Palette shapes) =
        [ mkElemC "Palette" (map aux shapes) ]
     where
	-- aux :: (ShapeName,(Shape,Ports,Maybe a)) -> Content ()
	aux (name,(shape,pPort:ports, info)) =
	  CElem (Elem "Symbol" []
		[ escapeString "ShapeName" name
		, makeTag "Shape"	$ toContents shape
		, makeTag "Ports"
			[ makeTag "Principals" [auxPort pPort]
			, makeTag "Auxiliaries" $ map auxPort ports]
		, makeTag "Info"	$ toContents info
		]) ()
	auxPort :: Port -> Content ()
	auxPort = makeTag "Port" . toContents
    parseContents = do
        { inElement "Palette" $ fmap Palette (many1 parseSymbol) }

parseSymbol :: (XmlContent a) => XMLParser (ShapeName,(Shape,Ports,Maybe a))
parseSymbol = do
    { inElement "Symbol" $ do
              { name  		<- inElement "ShapeName" $ XML.text
              ; shape 		<- inElement "Shape"     $ parseContents
              ; ([pP],aPs) 	<- inElement "Ports"     $ parsePorts
              ; info  		<- inElement "Info"      $ parseContents
              ; return (name,(shape,pP:aPs,info)) } }

parsePorts :: XMLParser (Ports,Ports)
parsePorts =
     do
	pPorts <- inElement "Principals" $ many1 parsePort -- principal ports
	aPorts <- inElement "Auxiliaries" $ many parsePort -- auxiliary ports
	return (pPorts, aPorts)

parsePort :: XMLParser Port
parsePort = inElement "Port" $ parseContents

instance HTypeable (INRule g n e) where
    toHType _ = Defined "INRule" [] [Constr "INRule" [] []]
instance (InfoKind n g, InfoKind e g, XmlContent g) =>
         XmlContent (INRule g n e) where
    toContents rule = 
        [CElem (Elem "INRule" []
                   [ escapeString  "Name"    (getName rule)
                   , makeTag       "LHS"     (toContents $ getLHS rule)
                   , makeTag       "RHS"     (toContents $ getRHS rule)
                   , makeTag       "Mapping" (map toContentsMappingElement
                                                        $ getMapping rule)
                   ]) () ]
      where
	toContentsMappingElement :: MappingElement -> Content ()
	toContentsMappingElement (nNr1,nNr2) =
		CElem (Elem "MappingElement"
			[ mkAttr "lhs" (show nNr1)
			, mkAttr "rhs" (show nNr2)
			] []) ()
    parseContents = do
        { inElement "INRule" $ do
              { nam <- inElement "Name"    $ XML.text
              ; lhs <- inElement "LHS"     $ parseContents
              ; rhs <- inElement "RHS"     $ parseContents
              ; maa <- inElement "Mapping" $ many parseMappingElement
              ; return ( INRule.construct nam lhs rhs maa)
              }
        }

parseMappingElement :: XMLParser MappingElement
parseMappingElement = do
	      { (p, e@(Elem _ [("lhs",nNr1),("rhs",nNr2)] [])) <- posnElement ["MappingElement"]
	      ; nNr1' <- attr2value nNr1
	      ; nNr2' <- attr2value nNr2
              ; return (nNr1', nNr2')
              }