module Wayland.CodeGen.Parser
  ( parseProtocolSpec
  ) where

import Data.Maybe (fromMaybe)
import Text.XML.Light (Element(..), findAttrBy, QName(..), filterChildName, filterChildrenName, strContent, parseXMLDoc)
import Text.Read (readEither)
import Wayland.CodeGen.Types

parseProtocolSpec :: String -> Either String Protocol
parseProtocolSpec s = case parseXMLDoc s of
                        Just el | matchName "protocol" (elName el) -> processProtocol el
                        _                                          -> Left "Invalid XML"

processProtocol :: Element -> Either String Protocol
processProtocol el = do
  name        <- requireAttr "name" el
  description <- traverse processDescription (filterChildName (matchName "description") el)
  interfaces  <- mapM processInterface (filterChildrenName (matchName "interface") el)
  let copyright = strContent <$> filterChildName (matchName "copyright") el
  pure $ Protocol { protName        = name
                  , protCopyright   = copyright
                  , protDescription = description
                  , protInterfaces  = interfaces
                  }

processDescription :: Element -> Either String Description
processDescription el = do
  summary <- requireAttr "summary" el
  pure $ Description { descSummary = summary
                     , descBody    = strContent el
                     }

processInterface :: Element -> Either String InterfaceDesc
processInterface el = do
  name        <- requireAttr "name" el
  version     <- requireAttr "version" el >>= readEither
  description <- mapM processDescription (filterChildName (matchName "description") el)
  enums       <- mapM processEnum (filterChildrenName (matchName "enum") el)
  requests    <- mapM processMessage (zip (filterChildrenName (matchName "request") el) [0..])
  events      <- mapM processMessage (zip (filterChildrenName (matchName "event"  ) el) [0..])
  pure $ InterfaceDesc { ifName        = name
                       , ifVersion     = version
                       , ifDescription = description
                       , ifEnums       = enums
                       , ifRequests    = requests
                       , ifEvents      = events
                       }

processEnum :: Element -> Either String EnumDesc
processEnum el = do
  name        <- requireAttr "name" el
  description <- mapM processDescription (filterChildName (matchName "description") el)
  since       <- mapM readEither (findAttrBy (matchName "since") el)
  bitfield    <- mapM readBool (findAttrBy (matchName "bitfield") el)
  entries     <- mapM processEntry (filterChildrenName (matchName "entry") el)
  pure $ EnumDesc { enumName        = name
                  , enumDescription = description
                  , enumSince       = fromMaybe 1 since
                  , enumBitfield    = fromMaybe False bitfield
                  , enumEntries     = entries
                  }

processEntry :: Element -> Either String EntryDesc
processEntry el = do
  name            <- requireAttr "name" el
  value           <- requireAttr "value" el >>= readEither
  description     <- mapM processDescription (filterChildName (matchName "description") el)
  since           <- mapM readEither (findAttrBy (matchName "since") el)
  deprecatedSince <- mapM readEither (findAttrBy (matchName "deprecated-since") el)
  let summary = findAttrBy (matchName "summary") el
  pure $ EntryDesc { entryName            = name
                   , entryValue           = value
                   , entryDescription     = description
                   , entrySummary         = summary
                   , entrySince           = fromMaybe 1 since
                   , entryDeprecatedSince = deprecatedSince
                   }

processMessage :: (Element, Int) -> Either String MessageDesc
processMessage (el, opcode) = do
  name            <- requireAttr "name" el
  description     <- mapM processDescription (filterChildName (matchName "description") el)
  type'           <- mapM readMessageType (findAttrBy (matchName "type") el)
  since           <- mapM readEither (findAttrBy (matchName "since") el)
  deprecatedSince <- mapM readEither (findAttrBy (matchName "deprecated-since") el)
  arguments       <- mapM processArgument (filterChildrenName (matchName "arg") el)
  pure $ MessageDesc { msgName            = name
                     , msgOpCode          = opcode
                     , msgDescription     = description
                     , msgType            = fromMaybe MessageNormal type'
                     , msgSince           = fromMaybe 1 since
                     , msgDeprecatedSince = deprecatedSince
                     , msgArguments       = arguments
                     }

processArgument :: Element -> Either String ArgumentDesc
processArgument el = do
  name        <- requireAttr "name" el
  type'       <- requireAttr "type" el >>= readArgumentType
  description <- mapM processDescription (filterChildName (matchName "description") el)
  allowNull   <- mapM readBool (findAttrBy (matchName "allow-null") el)
  let summary   = findAttrBy (matchName "summary") el
  let interface = findAttrBy (matchName "interface") el
  let enum      = findAttrBy (matchName "enum") el
  pure $ ArgumentDesc { argName        = name
                      , argType        = type'
                      , argDescription = description
                      , argSummary     = summary
                      , argInterface   = interface
                      , argEnum        = enum
                      , argAllowNull   = fromMaybe False allowNull
                      }

requireAttr :: String -> Element -> Either String String
requireAttr name el = expect ("Expected attribute " ++ name) $ findAttrBy (matchName name) el

matchName :: String -> QName -> Bool
matchName name q = qName q == name

expect :: String -> Maybe a -> Either String a
expect _ (Just x) = Right x
expect e Nothing  = Left e

readBool :: String -> Either String Bool
readBool "true"  = Right True
readBool "false" = Right False
readBool x       = Left $ "Expected a boolean value, got " ++ x

readMessageType :: String -> Either String MessageType
readMessageType "destructor" = Right MessageDestructor
readMessageType "normal"     = Right MessageNormal
readMessageType x            = Left $ "Expected a message type, got " ++ x

readArgumentType :: String -> Either String ArgumentType
readArgumentType "int"    = Right ArgumentInt
readArgumentType "uint"   = Right ArgumentUInt
readArgumentType "fixed"  = Right ArgumentFixed
readArgumentType "string" = Right ArgumentString
readArgumentType "array"  = Right ArgumentArray
readArgumentType "fd"     = Right ArgumentFD
readArgumentType "new_id" = Right ArgumentNewID
readArgumentType "object" = Right ArgumentObject
readArgumentType x        = Left $ "Expected an argument type, got " ++ x