{-# OPTIONS -fallow-undecidable-instances #-}

module NetworkFile where

import Network
import Math
import Common
import Colors
import Shape
import InfoKind
import Ports

import Text.XML.HaXml.Types
import Text.XML.HaXml.Escape
import Text.XML.HaXml.Posn (noPos)
import Text.XML.HaXml.Parse
import Text.XML.HaXml.XmlContent as XML
import Text.XML.HaXml.Combinators (replaceAttrs)
import Text.XML.HaXml.Verbatim
import Text.PrettyPrint.HughesPJ
import qualified Text.XML.HaXml.Pretty as Pretty
import Data.Char
import Data.Maybe
import Monad(when)
import Data.List(nub,isPrefixOf)

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

-- | Parses a string to the network data structure
--   Returns either an error message (Left) or the network,
--   a list of warnings (Right) and a boolean indicating whether
--   the file was an old Dazzle file
fromString :: (InfoKind n g, InfoKind e g, XmlContent g) =>
              String -> Either String (Network 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)

{-
-- non-XML output
toStringShow :: (Show g, Show n, Show e) => Network g n e -> String
toStringShow network =
    show ( getNodeAssocs network
         , getEdgeAssocs network
         , getCanvasSize network
         , getGlobalInfo network
         )

fromStringShow :: (Read g, InfoKind n g, InfoKind e g) =>
                  String -> Either String (Network g n e)
fromStringShow txt =
    case reads txt of
        ((tuple,[]):_) ->
            let (nodeAssocs, edgeAssocs, canvasSize, globalInfo) = tuple
            in Right ( setNodeAssocs nodeAssocs
                     . setEdgeAssocs edgeAssocs
                     . setCanvasSize canvasSize
                     $ Network.empty globalInfo undefined undefined
                     )
        _ -> Left "File is not a " ++ toolName ++ " network"
-}

---------------------------------------------------------
-- Internal type isomorphic to (index,value) pairs
-- (but permits instances of classes)
---------------------------------------------------------
data AssocN n = AssocN Int (Node n)
deAssocN :: AssocN n -> (Int,Node n)
deAssocN (AssocN n v) = (n,v)
data AssocE e = AssocE Int (Edge e)
deAssocE :: AssocE e -> (Int,Edge e)
deAssocE (AssocE n v) = (n,v)

---------------------------------------------------------
-- Convert our data type to/from an XML tree
---------------------------------------------------------
instance HTypeable (Network g n e) where
    toHType _ = Defined "Network" [] [Constr "Network" [] []]
instance (InfoKind n g, InfoKind e g, XmlContent g) =>
         XmlContent (Network g n e) where
    toContents network = 
        [CElem (Elem "Network"
                   [ mkAttr "Width"  (show width)
                   , mkAttr "Height" (show height)
		   ]
                   [ makeTag       "Info"      (toContents netInfo)
                   , makeTag       "Nodes"     (concatMap toContents nodeAssocs)
                   , makeTag       "Edges"     (concatMap toContents edgeAssocs)
                   ]) () ]
      where
        nodeAssocs = map (uncurry AssocN) $ getNodeAssocs network
        edgeAssocs = map (uncurry AssocE) $ getEdgeAssocs network
        (width, height) = getCanvasSize network
        netInfo = getGlobalInfo network
    parseContents = do
	      { (p, e@(Elem _ [("Width",w),("Height",h)] cs)) <- posnElement ["Network"]
	      ; reparse cs
	      ; w' <- attr2value w
	      ; h' <- attr2value h
              ; i  <- inElement "Info"   $ parseContents
              ; ns <- inElement "Nodes"  $ many parseContents
              ; es <- inElement "Edges"  $ many parseContents
              ; networkValid ns es
              ; return ( setCanvasSize (w',h')
                       . setNodeAssocs (map deAssocN ns)
                       . setEdgeAssocs (map deAssocE es)
                       $ Network.empty i undefined undefined)
              }

attr2value :: (Read a) => AttValue -> XMLParser a
attr2value (AttValue [Left n]) = return (read n)
attr2value (AttValue s) = fail ("Problem reading Node ID: "++verbatim s)

peekAttributes :: String -> XMLParser [(String,AttValue)]
peekAttributes t =
    do{ (p, e@(Elem _ as _)) <- posnElement [t]
      ; reparse [CElem e p]
      ; return as
      }

instance HTypeable (AssocN n) where
    toHType _ = Defined "Node" [] [Constr "Node" [] []]
instance (InfoKind n g) => XmlContent (AssocN n) where
    toContents (AssocN n node) =
        concatMap (replaceAttrs [("id",'N':show n)]) (toContents node)
    parseContents = do
        { [("id",n)] <- peekAttributes "Node"
        ; n' <- num n
        ; node <- parseContents
        ; return (AssocN n' node)
        }
      where num (AttValue [Left ('N':n)]) = return (read n)
            num (AttValue s) = fail ("Problem reading Node ID: "++verbatim s)

instance HTypeable (AssocE e) where
    toHType _ = Defined "Edge" [] [Constr "Edge" [] []]
instance (InfoKind e g) => XmlContent (AssocE e) where
    toContents (AssocE n edge) =
        concatMap (replaceAttrs [("id",'E':show n)]) (toContents edge)
    parseContents = do
        { [("id",n)] <- peekAttributes "Edge"
        ; n' <- num n
        ; edge <- parseContents
        ; return (AssocE n' edge)
        }
      where num (AttValue [Left ('E':n)]) = return (read n)
            num (AttValue s) = fail ("Problem reading Edge ID: "++verbatim s)

instance HTypeable (Node n) where
    toHType _ = Defined "Node" [] [Constr "Node" [] []]
instance (InfoKind n g) => XmlContent (Node n) where
    toContents node =
        [ makeTag "Node"
            (toContents (getPosition node) ++
            [ escapeString "Name"       (getName node)
            , simpleString "LabelAbove" (show (getNameAbove node))
            , escapeString "Shape"      (getShape node)
            , makeTag      "Info"       (toContents (getInfo node))
            ])
        ]
    parseContents = do
        { inElement "Node" $ do
              { p <- parseContents	-- position
              ; n <- inElement "Name" $ XML.text
              ; a <- inElement "LabelAbove" $ fmap read XML.text
              ; s <- inElement "Shape" $ XML.text
              ; i <- inElement "Info" $ parseContents
              ; return (constructNode n p a s i)
              }
        }

instance HTypeable DoublePoint where
    toHType _ = Defined "DoublePoint" [] [Constr "X" [] [], Constr "Y" [] []]
instance XmlContent DoublePoint where
    toContents (DoublePoint x y) = 
        [ CElem (Elem "Position"
		[ mkAttr "X"          (show x)
        	, mkAttr "Y"          (show y)
		] []) () ]
    parseContents = do
	      { (p, e@(Elem _ [("X",x),("Y",y)] [])) <- posnElement ["Position"]
	      ; x' <- attr2value x
	      ; y' <- attr2value y
              ; return (DoublePoint x' y')
              }

instance HTypeable (Edge e) where
    toHType _ = Defined "Edge" [] [Constr "Edge" [] []]
instance InfoKind e g => XmlContent (Edge e) where
    toContents edge =
        [ makeTag "Edge"
            [ simpleString  "From"      (show (getEdgeFrom edge))
            , escapeString  "PortFrom"  (getPortFrom edge)
            , simpleString  "To"        (show (getEdgeTo edge))
            , escapeString  "PortTo"    (getPortTo edge)
            , makeTag       "Via"       (concatMap toContents (getEdgeVia edge))
            , makeTag       "Info"      (toContents (getEdgeInfo edge))
            ]
        ]
        where maybeSnd = maybe Nothing (Just . snd)
    parseContents = do
        { inElement "Edge" $ do
              { f <- inElement "From" $ fmap read XML.text
              ; q <- inElement "PortFrom" $ XML.text
              ; t <- inElement "To" $ fmap read XML.text
              ; r <- inElement "PortTo" $ XML.text
              ; v <- inElement "Via" $ many parseContents
              ; i <- inElement "Info" $ parseContents
              ; return (constructEdge f q t r v i)
              }
        }

instance HTypeable Colour where
    toHType v = Defined "Colour" []
                   [Constr "RGB" [] [toHType aa,toHType ab,toHType ac]]
      where (RGB aa ab ac) = v
instance XmlContent Colour where
    parseContents = do
	      { (p, e@(Elem _ [("R",r),("G",g),("B",b)] [])) <- posnElement ["RGB"]
	      ; r' <- attr2value r
	      ; g' <- attr2value g
	      ; b' <- attr2value b
              ; return (RGB r' g' b')
              }
    toContents v@(RGB aa ab ac) =
        [CElem (Elem (showConstr 0 (toHType v))
                   [ mkAttr "R" (show aa)
                   , mkAttr "G" (show ab)
                   , mkAttr "B" (show ac)
		   ] []) () ]

{- derived by DrIFT -}
instance HTypeable Shape where
    toHType v =
	Defined "Shape" []
		[Constr "Circle" [] [toHType aa,toHType ab],
		 Constr "Polygon" [] [toHType ac,toHType ad],
		 Constr "Lines" [] [toHType ae,toHType af],
		 Constr "Points" [] [toHType ag,toHType ah],
		 Constr "Rectangle" [] [toHType ai,toHType aj,toHType ak],
		 Constr "Arc" []
			[toHType al,toHType am,toHType an,toHType ao,toHType ap]
		 ,Constr "Ellipse" [] [toHType aq,toHType ar,toHType as,toHType at],
		 Constr "EllipticArc" []
			[toHType au,toHType av,toHType aw,toHType ax,toHType ay,toHType az]
		 ,Constr "RoundRec" [] [toHType aA,toHType aB,toHType aC,toHType aD]
		 ,Constr "Text" [] [toHType aE,toHType aF],
		 Constr "Composite" [] [toHType aG],
		 Constr "TextInEllipse" [] [toHType aH,toHType aI]]
      where
	(Circle aa ab) = v
	(Polygon ac ad) = v
	(Lines ae af) = v
	(Points ag ah) = v
	(Rectangle ai aj ak) = v
	(Arc al am an ao ap) = v
	(Ellipse aq ar as at) = v
	(EllipticArc au av aw ax ay az) = v
	(RoundRec aA aB aC aD) = v
	(Text aE aF) = v
	(Composite aG) = v
	(TextInEllipse aH aI) = v

instance XmlContent Shape where
    parseContents = do
	{ e@(Elem t _ _) <- elementWith (flip isPrefixOf) ["TextInEllipse","Text","RoundRec","Rectangle","Polygon","Points","Lines","EllipticArc","Ellipse","Composite","Circle","Arc"]
	; case t of
	  _ | "TextInEllipse" `isPrefixOf` t -> interior e $
		    return TextInEllipse `apply` parseContents `apply` parseContents
	    | "Text" `isPrefixOf` t -> interior e $
		    return Text `apply` parseContents `apply` parseContents
	    | "RoundRec" `isPrefixOf` t -> interior e $
		    return RoundRec `apply` parseContents `apply` parseContents
				    `apply` parseContents `apply` parseContents
	    | "Rectangle" `isPrefixOf` t -> interior e $
		    return Rectangle `apply` parseContents `apply` parseContents
				     `apply` parseContents
	    | "Polygon" `isPrefixOf` t -> interior e $
		    return Polygon `apply` parseContents `apply` parseContents
	    | "Points" `isPrefixOf` t -> interior e $
		    return Points `apply` parseContents `apply` parseContents
	    | "Lines" `isPrefixOf` t -> interior e $
		    return Lines `apply` parseContents `apply` parseContents
	    | "EllipticArc" `isPrefixOf` t -> interior e $
		    return EllipticArc `apply` parseContents `apply` parseContents
				       `apply` parseContents `apply` parseContents
				       `apply` parseContents `apply` parseContents
	    | "Ellipse" `isPrefixOf` t -> interior e $
		    return Ellipse `apply` parseContents `apply` parseContents
				   `apply` parseContents `apply` parseContents
	    | "Composite" `isPrefixOf` t -> interior e $ fmap Composite parseContents
	    | "Circle" `isPrefixOf` t -> interior e $
		    return Circle `apply` parseContents `apply` parseContents
	    | "Arc" `isPrefixOf` t -> interior e $
		    return Arc `apply` parseContents `apply` parseContents
			       `apply` parseContents `apply` parseContents `apply` parseContents
	}
    toContents v@(Circle aa ab) =
	[mkElemC (showConstr 0 (toHType v)) (concat [toContents aa,
						     toContents ab])]
    toContents v@(Polygon ac ad) =
	[mkElemC (showConstr 1 (toHType v)) (concat [toContents ac,
						     toContents ad])]
    toContents v@(Lines ae af) =
	[mkElemC (showConstr 2 (toHType v)) (concat [toContents ae,
						     toContents af])]
    toContents v@(Points ag ah) =
	[mkElemC (showConstr 3 (toHType v)) (concat [toContents ag,
						     toContents ah])]
    toContents v@(Rectangle ai aj ak) =
	[mkElemC (showConstr 4 (toHType v)) (concat [toContents ai,
						     toContents aj,toContents ak])]
    toContents v@(Arc al am an ao ap) =
	[mkElemC (showConstr 5 (toHType v)) (concat [toContents al,
						     toContents am,toContents an,toContents ao,
						     toContents ap])]
    toContents v@(Ellipse aq ar as at) =
	[mkElemC (showConstr 6 (toHType v)) (concat [toContents aq,
						     toContents ar,toContents as,toContents at])]
    toContents v@(EllipticArc au av aw ax ay az) =
	[mkElemC (showConstr 7 (toHType v)) (concat [toContents au,
						     toContents av,toContents aw,toContents ax,
						     toContents ay,toContents az])]
    toContents v@(RoundRec aA aB aC aD) =
	[mkElemC (showConstr 8 (toHType v)) (concat [toContents aA,
						     toContents aB,toContents aC,toContents aD])]
    toContents v@(Text aE aF) =
	[mkElemC (showConstr 9 (toHType v)) (concat [toContents aE,
						     toContents aF])]
    toContents v@(Composite aG) =
	[mkElemC (showConstr 10 (toHType v)) (toContents aG)]
    toContents v@(TextInEllipse aH aI) =
	[mkElemC (showConstr 11 (toHType v)) (concat [toContents aH,
						      toContents aI])]

{- derived by DrIFT -}
instance HTypeable ShapeStyle where
    toHType v = Defined "ShapeStyle" []
                    [Constr "ShapeStyle" [] [toHType aa,toHType ab,toHType ac]]
      where (ShapeStyle aa ab ac) = v
instance XmlContent ShapeStyle where
    parseContents = do
        { inElement  "ShapeStyle" $ do
              { aa <- parseContents
              ; ab <- parseContents
              ; ac <- parseContents
              ; return (ShapeStyle aa ab ac)
              }
        }
    toContents v@(ShapeStyle aa ab ac) =
        [mkElemC (showConstr 0 (toHType v))
                 (concat [toContents aa, toContents ab, toContents ac])]


---- UTILITY FUNCTIONS

-- Abbreviations
makeTag :: String -> [Content i] -> Content i
makeTag name children = CElem (Elem name [] children) undefined

tagWithId :: String -> String -> [Content i] -> Content i
tagWithId name identity children =
    CElem (Elem name [("id", AttValue [Left identity])] children) undefined

-- | A simple string contains no spaces or unsafe characters
simpleString :: String -> String -> Content i
simpleString tag value =
    CElem (Elem tag [] [ CString False value undefined ]) undefined

-- | The string value may contain spaces and unsafe characters
escapeString :: String -> String -> Content i
escapeString key value =
    CElem (Elem key [] [ CString True value undefined ]) undefined

comment :: String -> Content i
comment s = CMisc (Comment (commentEscape s)) undefined

-- Replace occurences of "-->" with "==>" in a string so that the string
-- becomes safe for an XML comment
commentEscape :: String -> String
commentEscape [] = []
commentEscape ('-':'-':'>':xs) = "==>" ++ commentEscape xs
commentEscape (x:xs) = x : commentEscape xs

---------------------------------------------------------
-- Check whether the network read from file is valid
---------------------------------------------------------

networkValid :: [AssocN n] -> [AssocE e] -> XMLParser ()
networkValid nodeAssocs edgeAssocs
    | containsDuplicates nodeNrs =
        fail "Node numbers should be unique"
    | containsDuplicates edgeNrs =
        fail "Edge numbers should be unique"
    | otherwise =
          do{ mapM_ (checkEdge nodeNrs) edgeAssocs
            ; -- determine whether there are multiple edges between any two nodes
            ; let multipleEdges = duplicatesBy betweenSameNodes edges
            ; when (not (null multipleEdges)) $
                fail $ "There are multiple edges between the following node pairs: " ++
                    commasAnd [ "(" ++ show (getEdgeFrom e) ++ ", "
                                    ++ show (getEdgeTo e) ++ ")"
                              | e <- multipleEdges
                              ]
            ; return ()
            }
  where
    nodeNrs = map (fst . deAssocN) nodeAssocs
    (edgeNrs, edges) = unzip (map deAssocE edgeAssocs)

-- Check whether edges refer to existing node numbers and whether
-- there are no edges that start and end in the same pair (node, port)
checkEdge :: [NodeNr] -> AssocE e -> XMLParser ()
checkEdge nodeNrs (AssocE edgeNr edge)
    | (fromNr, fromPort) == (toNr, toPort) =
        fail $ "Edge " ++ show edgeNr ++ ": from-node and to-node are the same"
    | fromNr `notElem` nodeNrs = nonExistingNode fromNr
    | toNr   `notElem` nodeNrs = nonExistingNode toNr
    | otherwise                = return ()
  where
    fromNr   = getEdgeFrom edge
    fromPort = getPortFrom edge
    toNr     = getEdgeTo   edge
    toPort   = getPortTo   edge
    nonExistingNode nodeNr =
        fail $ "Edge " ++ show edgeNr ++ ": refers to non-existing node "
               ++ show nodeNr

containsDuplicates :: Eq a => [a] -> Bool
containsDuplicates xs = length (nub xs) /= length xs

-- Partial equality on edges
betweenSameNodes :: Edge e -> Edge e -> Bool
betweenSameNodes e1 e2 =
    (    getEdgeFrom e1 == getEdgeFrom e2  &&  getEdgeTo e1 == getEdgeTo e2 
      && getPortFrom e1 == getPortFrom e2  &&  getPortTo e1 == getPortTo e2 )
    ||
    (    getEdgeFrom e1 == getEdgeTo e2    &&  getEdgeTo e1 == getEdgeFrom e1
      && getPortFrom e1 == getPortTo e2    &&  getPortTo e1 == getPortFrom e2 )

-- Returns elements that appear more than once in a list
duplicates :: Eq a => [a] -> [a]
duplicates [] = []
duplicates (x:xs)
    | x `elem` xs = x : duplicates (filter (/= x) xs)
    | otherwise   = duplicates xs

-- Returns elements that appear more than once in a list, using given Eq op
duplicatesBy :: (a->a->Bool) -> [a] -> [a]
duplicatesBy _  [] = []
duplicatesBy eq (x:xs)
    | any (eq x) xs = x : duplicatesBy eq (filter (not . eq x) xs)
    | otherwise     = duplicatesBy eq xs