--
-- Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
--
-- SPDX-License-Identifier: BSD-2-Clause
--
module CapDL.PrintXml (printXml) where

import CapDL.Model
import CapDL.PrintUtils

import Prelude ()
import Prelude.Compat
import Text.PrettyPrint
import Data.Maybe (fromMaybe)
import qualified Data.Map as Map
import qualified Data.Set as Set

indent = 4

-- XML header
xml_header = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"

--
-- Convert a list of key/value pairs into an XML tag attribute string.
--
-- > showXmlAttrsString [("name", "rover"), ("colour", "red")]
-- 'name="rover" colour="red"'
--
showXmlAttrsString :: [(String, String)] -> String
showXmlAttrsString attrs = foldl (\a b -> a ++ " " ++ b) "" joinedAttrs
  where
    joinedAttrs = (map (\(a, b) -> a ++ "=\"" ++ b ++ "\"") attrs)

--
-- Create an XML opening tag, filled with the given attributes.
--
openTag :: String -> [(String, String)] -> String
openTag x [] = "<" ++ x ++ ">"
openTag x attrs = "<" ++ x ++ attrsString ++ ">"
  where
    attrsString = showXmlAttrsString attrs

--
-- Create an XML closing tag.
--
closeTag :: String -> String
closeTag x = "</" ++ x ++ ">"

--
-- Create an empty XML tag.
--
emptyTag :: String -> [(String, String)] -> String
emptyTag x [] = "<" ++ x ++ " />"
emptyTag x attrs = "<" ++ x ++ attrsString ++ " />"
  where
    attrsString = showXmlAttrsString attrs

--
-- Surround the given document with the given tag.
--
xmlSurround :: String -> [(String, String)] -> Doc -> Doc
xmlSurround tag attrs details =
    (text (openTag tag attrs)) $+$ (nest indent details) $+$ (text (closeTag tag))

showCapRef :: CapRef -> String
showCapRef (obj, slot) = "(" ++ showID obj ++ ", " ++ show slot ++ ")"

--
-- Convert CapRights into a string.
--
showRights :: CapRights -> String
showRights rights = readRight ++ writeRight ++ grantRight ++ grantReplyRight
    where
        readRight = if Read `Set.member` rights then "r" else ""
        writeRight = if Write `Set.member` rights then "w" else ""
        grantRight = if Grant `Set.member` rights then "g" else ""
        grantReplyRight = if GrantReply `Set.member` rights then "p" else ""

--
-- Get an object's attributes.
--
showObjectAttrs :: KernelObject a -> [(String, String)]
showObjectAttrs (TCB _ _ _ domain _) = [("domain", show domain)]
showObjectAttrs (CNode _ sz _) = [("size", show sz)]
showObjectAttrs (Untyped (Just sz) paddr) = [("size", show sz), ("paddr", show $ fromMaybe 0 paddr)]
showObjectAttrs (Frame sz paddr _) = [("size", show sz), ("paddr", show $ fromMaybe 0 paddr)]
showObjectAttrs (IOPorts sz) = [("size", show sz)]
showObjectAttrs (IODevice _ dom pci) = [("domain", show dom), ("device", show pci)]
showObjectAttrs (ARMIODevice _ iospace) = [("iospace", show iospace)]
showObjectAttrs (IOPT _ level) = [("level", show level)]
showObjectAttrs _ = []

--
-- Get an object's name.
--
showObjectName :: KernelObject a -> String
showObjectName Endpoint = "Endpoint"
showObjectName Notification = "Notification"
showObjectName TCB {} = "TCB"
showObjectName CNode {} = "CNode"
showObjectName Untyped {} = "Untyped"
showObjectName ASIDPool {} = "ASIDPool"
showObjectName PT {} = "PT"
showObjectName PD {} = "PD"
showObjectName PDPT {} = "PDPT"
showObjectName PML4 {} = "PML4"
showObjectName PUD {} = "PUD"
showObjectName PGD {} = "PGD"
showObjectName Frame {} = "Frame"
showObjectName IOPorts {} = "IOPorts"
showObjectName IODevice {} = "IODevice"
showObjectName ARMIODevice {} = "ARMIODevice"
showObjectName IOPT {} = "IOPT"
showObjectName VCPU {} = "VCPU"
showObjectName SC {} = "SC"
showObjectName RTReply {} = "RTReply"
showObjectName IOAPICIrq {} = "IOAPICIrq"
showObjectName MSIIrq {} = "MSIIrq"
showObjectName ARMIrq {} = "ARMIrq"
showObjectName ARMSID {} = "ARMSID"
showObjectName ARMCB {} = "ARMCB"

--
-- Get a cap's name.
--
showCapName :: Cap -> String
showCapName NullCap = "NullCap"
showCapName UntypedCap {} = "UntypedCap"
showCapName EndpointCap {} = "EndpointCap"
showCapName NotificationCap {} = "NotificationCap"
showCapName ReplyCap {} = "ReplyCap"
showCapName MasterReplyCap {} = "MasterReplyCap"
showCapName CNodeCap {} = "CNodeCap"
showCapName TCBCap {} = "TCBCap"
showCapName IRQControlCap = "IRQControlCap"
showCapName IRQHandlerCap {} = "IRQHandlerCap"
showCapName IRQIOAPICHandlerCap {} = "IRQIOAPICHandlerCap"
showCapName IRQMSIHandlerCap {} = "IRQMSIHandlerCap"
showCapName ARMIRQHandlerCap {} = "ARMIRQHandlerCap"
showCapName DomainCap = "DomainCap"
showCapName FrameCap {} = "FrameCap"
showCapName PTCap {} = "PTCap"
showCapName PDCap {} = "PDCap"
showCapName PDPTCap {} = "PDPTCap"
showCapName PML4Cap {} = "PML4Cap"
showCapName PUDCap {} = "PUDCap"
showCapName PGDCap {} = "PGDCap"
showCapName ASIDControlCap = "ASIDControlCap"
showCapName ASIDPoolCap {} = "ASIDPoolCap"
showCapName IOPortsCap {} = "IOPortsCap"
showCapName IOSpaceMasterCap = "IOSpaceMasterCap"
showCapName IOSpaceCap {} = "IOSpaceCap"
showCapName ARMIOSpaceCap {} = "ARMIOSpaceCap"
showCapName IOPTCap {} = "IOPTCap"
showCapName VCPUCap {} = "VCPUCap"
showCapName SCCap {} = "SCCap"
showCapName RTReplyCap {} = "RTReplyCap"
showCapName SchedControlCap {} = "SchedControlCap"
showCapName ARMSIDCap {} = "ARMSIDCap"
showCapName ARMCBCap {} = "ARMCBCap"

showExtraCapAttributes :: Cap -> [(String, String)]
showExtraCapAttributes (EndpointCap _ capBadge _) = [("badge", show capBadge)]
showExtraCapAttributes (NotificationCap _ capBadge _) = [("badge", show capBadge)]
showExtraCapAttributes (CNodeCap _ guard guardSize) =
    [("guard", show guard), ("guardSize", show guardSize)]
showExtraCapAttributes (FrameCap _ _ _ False _) = [("cached", "False")]
showExtraCapAttributes _ = []

--
-- Print the XML for the given cap.
--
printCapXml :: (Word, Cap) -> Doc
printCapXml (location, cap) =
    text (emptyTag "cap" (captype ++ slot ++ target ++ rights ++ attrs))
    where
        slot = [("slot", show location)]
        captype = [("type", showCapName cap)]
        target = if hasObjID cap then [("id", showID (objID cap))] else [("id", "global" ++ showCapName cap)]
        rights = if hasRights cap then [("rights", showRights (capRights cap))] else []
        attrs = showExtraCapAttributes cap

--
-- Print the XML for a CapMap
--
printCapMap :: CapMap Word -> Doc
printCapMap x =
    vcat (map printCapXml (Map.toList x))

--
-- Print an object that just has a name and some simple attributes.
--
printSimpleObject :: KernelObject Word -> ObjID -> [(String, String)] -> Doc
printSimpleObject object objId attrs =
    if hasSlots object then
        (xmlSurround "object" all_attrs $ printCapMap (slots object))
    else
        text (emptyTag "object" all_attrs)
    where
        all_attrs = [("id", showID objId), ("type", showObjectName object)] ++ attrs

--
-- Print the given object.
--
printObject :: (ObjID, KernelObject Word) -> Doc
printObject (objId, object) =
    printSimpleObject object objId (showObjectAttrs object)

-- Print the contents of all objects in the given heap.
printObjects :: ObjMap Word -> Doc
printObjects x =
    xmlSurround "objects" [] $ vcat (map printObject (Map.toList x))

printCovered :: [ObjID] -> Doc
printCovered objs =
    xmlSurround "covered" [] ids
    where ids = vcat $ map text $ map (\obj -> emptyTag "id" [("id", showID obj)]) objs

printCover :: (ObjID, [ObjID]) -> Doc
printCover (untyped, cover) =
    xmlSurround "cover" [("untyped", showID untyped)] $ printCovered cover

printUntypedCovers :: CoverMap -> Doc
printUntypedCovers untypedCovers =
    xmlSurround "untypedCovers" [] $ vcat (map printCover (Map.toList untypedCovers))

printCDTRelation :: (CapRef, CapRef) -> Doc
printCDTRelation (child, parent) =
    text $ emptyTag "cdtRelation" [("child", showCapRef child), ("parent", showCapRef parent)]

printCDT :: CDT -> Doc
printCDT cdt =
    xmlSurround "cdt" [] $ vcat (map printCDTRelation (Map.toList cdt))

-- Print the contents of a model in XML format.
printXml :: String -> Model Word -> Doc
printXml _ (Model arch ms _ cdt untypedCovers) =
    text xml_header
        $+$ (xmlSurround "model" [("arch", show arch)] $ printObjects ms $+$ printUntypedCovers untypedCovers $+$ printCDT cdt)
        $+$ text "\n"