-- | The Parser monad.
module Data.GI.GIR.Parser
    ( Parser
    , ParseContext(..)
    , ParseError
    , parseError

    , runParser

    , parseName
    , parseDeprecation
    , parseDocumentation
    , parseIntegral
    , parseBool
    , parseChildrenWithLocalName
    , parseAllChildrenWithLocalName
    , parseChildrenWithNSName

    , getAttr
    , getAttrWithNamespace
    , queryAttr
    , queryAttrWithNamespace
    , optionalAttr

    , currentNamespace
    , qualifyName
    , resolveQualifiedTypeName

    -- Reexported for convenience
    , Name(..)
    , Element
    , GIRXMLNamespace(..)
    , DeprecationInfo
    , Documentation
    ) where

import Control.Monad.Except
import Control.Monad.Reader

#if !MIN_VERSION_base(4,11,0)
import Data.Monoid ((<>))
#endif
import qualified Data.Map as M
import qualified Data.Text as T
import qualified Data.Text.Read as TR
import Data.Text (Text)
import qualified Text.XML as XML
import Text.XML (Element(elementAttributes))
import Text.Show.Pretty (ppShow)

import Data.GI.GIR.BasicTypes (Name(..), Alias(..), Type(TInterface))
import Data.GI.GIR.Deprecation (DeprecationInfo, queryDeprecated)
import Data.GI.GIR.Documentation (Documentation, queryDocumentation)
import Data.GI.GIR.XMLUtils (localName, GIRXMLNamespace(..),
                        childElemsWithLocalName, childElemsWithNSName,
                        lookupAttr, lookupAttrWithNamespace)

-- | Info to carry around when parsing.
data ParseContext = ParseContext {
      ParseContext -> ParseError
ctxNamespace     :: Text,
      -- Location in the XML tree of the node being parsed (for
      -- debugging purposes).
      ParseContext -> [ParseError]
treePosition     :: [Text],
      -- Current element being parsed (to be set by withElement)
      ParseContext -> Element
currentElement   :: Element,
      ParseContext -> Map Alias Type
knownAliases     :: M.Map Alias Type
    } deriving Int -> ParseContext -> ShowS
[ParseContext] -> ShowS
ParseContext -> String
(Int -> ParseContext -> ShowS)
-> (ParseContext -> String)
-> ([ParseContext] -> ShowS)
-> Show ParseContext
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ParseContext -> ShowS
showsPrec :: Int -> ParseContext -> ShowS
$cshow :: ParseContext -> String
show :: ParseContext -> String
$cshowList :: [ParseContext] -> ShowS
showList :: [ParseContext] -> ShowS
Show

-- | A message describing a parsing error in human readable form.
type ParseError = Text

-- | Monad where parsers live: we carry a context around, and can
-- throw errors that abort the parsing.
type Parser a = ReaderT ParseContext (Except ParseError) a

-- | Throw a parse error.
parseError :: ParseError -> Parser a
parseError :: forall a. ParseError -> Parser a
parseError ParseError
msg = do
  ctx <- ReaderT ParseContext (Except ParseError) ParseContext
forall r (m :: * -> *). MonadReader r m => m r
ask
  let position = (ParseError -> [ParseError] -> ParseError
T.intercalate ParseError
" / " ([ParseError] -> ParseError)
-> (ParseContext -> [ParseError]) -> ParseContext -> ParseError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ParseError] -> [ParseError]
forall a. [a] -> [a]
reverse ([ParseError] -> [ParseError])
-> (ParseContext -> [ParseError]) -> ParseContext -> [ParseError]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseContext -> [ParseError]
treePosition) ParseContext
ctx
  throwError $ "Error when parsing \"" <> position <> "\": " <> msg <> "\n"
                 <> (T.pack . ppShow . currentElement) ctx

-- | Build a textual description (for debug purposes) of a given element.
elementDescription :: Element -> Text
elementDescription :: Element -> ParseError
elementDescription Element
element =
    case Name -> Map Name ParseError -> Maybe ParseError
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
"name" (Element -> Map Name ParseError
elementAttributes Element
element) of
      Maybe ParseError
Nothing -> Element -> ParseError
localName Element
element
      Just ParseError
n -> Element -> ParseError
localName Element
element ParseError -> ParseError -> ParseError
forall a. Semigroup a => a -> a -> a
<> ParseError
" [" ParseError -> ParseError -> ParseError
forall a. Semigroup a => a -> a -> a
<> ParseError
n ParseError -> ParseError -> ParseError
forall a. Semigroup a => a -> a -> a
<> ParseError
"]"

-- | Build a name in the current namespace.
nameInCurrentNS :: Text -> Parser Name
nameInCurrentNS :: ParseError -> Parser Name
nameInCurrentNS ParseError
n = do
  ctx <- ReaderT ParseContext (Except ParseError) ParseContext
forall r (m :: * -> *). MonadReader r m => m r
ask
  return $ Name (ctxNamespace ctx) n

-- | Return the current namespace.
currentNamespace :: Parser Text
currentNamespace :: Parser ParseError
currentNamespace = ParseContext -> ParseError
ctxNamespace (ParseContext -> ParseError)
-> ReaderT ParseContext (Except ParseError) ParseContext
-> Parser ParseError
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT ParseContext (Except ParseError) ParseContext
forall r (m :: * -> *). MonadReader r m => m r
ask

-- | Check whether there is an alias for the given name, and return
-- the corresponding type in case it exists, and otherwise a TInterface.
resolveQualifiedTypeName :: Name -> Parser Type
resolveQualifiedTypeName :: Name -> Parser Type
resolveQualifiedTypeName Name
name = do
  ctx <- ReaderT ParseContext (Except ParseError) ParseContext
forall r (m :: * -> *). MonadReader r m => m r
ask
  case M.lookup (Alias name) (knownAliases ctx) of
    -- The resolved type may be an alias itself, like for
    -- Gtk.Allocation -> Gdk.Rectangle -> cairo.RectangleInt
    Just (TInterface Name
n) -> Name -> Parser Type
resolveQualifiedTypeName Name
n
    Just Type
t -> Type -> Parser Type
forall a. a -> ReaderT ParseContext (Except ParseError) a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t
    Maybe Type
Nothing -> Type -> Parser Type
forall a. a -> ReaderT ParseContext (Except ParseError) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Parser Type) -> Type -> Parser Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
TInterface Name
name

-- | Return the value of an attribute for the given element. If the
-- attribute is not present this throws an error.
getAttr :: XML.Name -> Parser Text
getAttr :: Name -> Parser ParseError
getAttr Name
attr = do
  ctx <- ReaderT ParseContext (Except ParseError) ParseContext
forall r (m :: * -> *). MonadReader r m => m r
ask
  case lookupAttr attr (currentElement ctx) of
    Just ParseError
val -> ParseError -> Parser ParseError
forall a. a -> ReaderT ParseContext (Except ParseError) a
forall (m :: * -> *) a. Monad m => a -> m a
return ParseError
val
    Maybe ParseError
Nothing -> ParseError -> Parser ParseError
forall a. ParseError -> Parser a
parseError (ParseError -> Parser ParseError)
-> ParseError -> Parser ParseError
forall a b. (a -> b) -> a -> b
$ ParseError
"Expected attribute \"" ParseError -> ParseError -> ParseError
forall a. Semigroup a => a -> a -> a
<>
               (String -> ParseError
T.pack (String -> ParseError) -> (Name -> String) -> Name -> ParseError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
forall a. Show a => a -> String
show) Name
attr ParseError -> ParseError -> ParseError
forall a. Semigroup a => a -> a -> a
<> ParseError
"\" not present."

-- | Like 'getAttr', but allow for specifying the namespace.
getAttrWithNamespace :: GIRXMLNamespace -> XML.Name -> Parser Text
getAttrWithNamespace :: GIRXMLNamespace -> Name -> Parser ParseError
getAttrWithNamespace GIRXMLNamespace
ns Name
attr = do
  ctx <- ReaderT ParseContext (Except ParseError) ParseContext
forall r (m :: * -> *). MonadReader r m => m r
ask
  case lookupAttrWithNamespace ns attr (currentElement ctx) of
    Just ParseError
val -> ParseError -> Parser ParseError
forall a. a -> ReaderT ParseContext (Except ParseError) a
forall (m :: * -> *) a. Monad m => a -> m a
return ParseError
val
    Maybe ParseError
Nothing -> ParseError -> Parser ParseError
forall a. ParseError -> Parser a
parseError (ParseError -> Parser ParseError)
-> ParseError -> Parser ParseError
forall a b. (a -> b) -> a -> b
$ ParseError
"Expected attribute \"" ParseError -> ParseError -> ParseError
forall a. Semigroup a => a -> a -> a
<>
               (String -> ParseError
T.pack (String -> ParseError) -> (Name -> String) -> Name -> ParseError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
forall a. Show a => a -> String
show) Name
attr ParseError -> ParseError -> ParseError
forall a. Semigroup a => a -> a -> a
<> ParseError
"\" in namespace \"" ParseError -> ParseError -> ParseError
forall a. Semigroup a => a -> a -> a
<>
               (String -> ParseError
T.pack (String -> ParseError)
-> (GIRXMLNamespace -> String) -> GIRXMLNamespace -> ParseError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GIRXMLNamespace -> String
forall a. Show a => a -> String
show) GIRXMLNamespace
ns ParseError -> ParseError -> ParseError
forall a. Semigroup a => a -> a -> a
<> ParseError
"\" not present."

-- | Return the value of an attribute if it is present, and Nothing otherwise.
queryAttr :: XML.Name -> Parser (Maybe Text)
queryAttr :: Name -> Parser (Maybe ParseError)
queryAttr Name
attr = do
  ctx <- ReaderT ParseContext (Except ParseError) ParseContext
forall r (m :: * -> *). MonadReader r m => m r
ask
  return $ lookupAttr attr (currentElement ctx)

-- | Like `queryAttr`, but allow for specifying the namespace.
queryAttrWithNamespace :: GIRXMLNamespace -> XML.Name -> Parser (Maybe Text)
queryAttrWithNamespace :: GIRXMLNamespace -> Name -> Parser (Maybe ParseError)
queryAttrWithNamespace GIRXMLNamespace
ns Name
attr = do
  ctx <- ReaderT ParseContext (Except ParseError) ParseContext
forall r (m :: * -> *). MonadReader r m => m r
ask
  return $ lookupAttrWithNamespace ns attr (currentElement ctx)

-- | Ask for an optional attribute, applying the given parser to
-- it. If the argument does not exist return the default value provided.
optionalAttr :: XML.Name -> a -> (Text -> Parser a) -> Parser a
optionalAttr :: forall a. Name -> a -> (ParseError -> Parser a) -> Parser a
optionalAttr Name
attr a
def ParseError -> Parser a
parser =
    Name -> Parser (Maybe ParseError)
queryAttr Name
attr Parser (Maybe ParseError)
-> (Maybe ParseError -> Parser a) -> Parser a
forall a b.
ReaderT ParseContext (Except ParseError) a
-> (a -> ReaderT ParseContext (Except ParseError) b)
-> ReaderT ParseContext (Except ParseError) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Just ParseError
a -> ParseError -> Parser a
parser ParseError
a
              Maybe ParseError
Nothing -> a -> Parser a
forall a. a -> ReaderT ParseContext (Except ParseError) a
forall (m :: * -> *) a. Monad m => a -> m a
return a
def

-- | Build a 'Name' out of the (possibly qualified) supplied name. If
-- the supplied name is unqualified we qualify with the current
-- namespace, and otherwise we simply parse it.
qualifyName :: Text -> Parser Name
qualifyName :: ParseError -> Parser Name
qualifyName ParseError
n = case (Char -> Bool) -> ParseError -> [ParseError]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') ParseError
n of
    [ParseError
ns, ParseError
name] -> Name -> Parser Name
forall a. a -> ReaderT ParseContext (Except ParseError) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Parser Name) -> Name -> Parser Name
forall a b. (a -> b) -> a -> b
$ ParseError -> ParseError -> Name
Name ParseError
ns ParseError
name
    [ParseError
name] -> ParseError -> Parser Name
nameInCurrentNS ParseError
name
    [ParseError]
_ -> ParseError -> Parser Name
forall a. ParseError -> Parser a
parseError ParseError
"Could not understand name"

-- | Get the qualified name for the current element.
parseName :: Parser Name
parseName :: Parser Name
parseName = Name -> Parser ParseError
getAttr Name
"name" Parser ParseError -> (ParseError -> Parser Name) -> Parser Name
forall a b.
ReaderT ParseContext (Except ParseError) a
-> (a -> ReaderT ParseContext (Except ParseError) b)
-> ReaderT ParseContext (Except ParseError) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ParseError -> Parser Name
qualifyName

-- | Parse the deprecation text, if present.
parseDeprecation :: Parser (Maybe DeprecationInfo)
parseDeprecation :: Parser (Maybe DeprecationInfo)
parseDeprecation = do
  ctx <- ReaderT ParseContext (Except ParseError) ParseContext
forall r (m :: * -> *). MonadReader r m => m r
ask
  return $ queryDeprecated (currentElement ctx)

-- | Parse the documentation info for the current node.
parseDocumentation :: Parser Documentation
parseDocumentation :: Parser Documentation
parseDocumentation = do
  ctx <- ReaderT ParseContext (Except ParseError) ParseContext
forall r (m :: * -> *). MonadReader r m => m r
ask
  return $ queryDocumentation (currentElement ctx)

-- | Parse a signed integral number.
parseIntegral :: Integral a => Text -> Parser a
parseIntegral :: forall a. Integral a => ParseError -> Parser a
parseIntegral ParseError
str =
    case Reader a -> Reader a
forall a. Num a => Reader a -> Reader a
TR.signed Reader a
forall a. Integral a => Reader a
TR.decimal ParseError
str of
      Right (a
n, ParseError
r) | ParseError -> Bool
T.null ParseError
r -> a -> Parser a
forall a. a -> ReaderT ParseContext (Except ParseError) a
forall (m :: * -> *) a. Monad m => a -> m a
return a
n
      Either String (a, ParseError)
_ -> ParseError -> Parser a
forall a. ParseError -> Parser a
parseError (ParseError -> Parser a) -> ParseError -> Parser a
forall a b. (a -> b) -> a -> b
$ ParseError
"Could not parse integral value: \"" ParseError -> ParseError -> ParseError
forall a. Semigroup a => a -> a -> a
<> ParseError
str ParseError -> ParseError -> ParseError
forall a. Semigroup a => a -> a -> a
<> ParseError
"\"."

-- | A boolean value given by a numerical constant.
parseBool :: Text -> Parser Bool
parseBool :: ParseError -> Parser Bool
parseBool ParseError
"0" = Bool -> Parser Bool
forall a. a -> ReaderT ParseContext (Except ParseError) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
parseBool ParseError
"1" = Bool -> Parser Bool
forall a. a -> ReaderT ParseContext (Except ParseError) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
parseBool ParseError
other = ParseError -> Parser Bool
forall a. ParseError -> Parser a
parseError (ParseError -> Parser Bool) -> ParseError -> Parser Bool
forall a b. (a -> b) -> a -> b
$ ParseError
"Unsupported boolean value: " ParseError -> ParseError -> ParseError
forall a. Semigroup a => a -> a -> a
<> String -> ParseError
T.pack (ParseError -> String
forall a. Show a => a -> String
show ParseError
other)

-- | Parse all the introspectable subelements with the given local name.
parseChildrenWithLocalName :: Text -> Parser a -> Parser [a]
parseChildrenWithLocalName :: forall a. ParseError -> Parser a -> Parser [a]
parseChildrenWithLocalName ParseError
n Parser a
parser = do
  ctx <- ReaderT ParseContext (Except ParseError) ParseContext
forall r (m :: * -> *). MonadReader r m => m r
ask
  let introspectableChildren = (Element -> Bool) -> [Element] -> [Element]
forall a. (a -> Bool) -> [a] -> [a]
filter Element -> Bool
introspectable
                               (ParseError -> Element -> [Element]
childElemsWithLocalName ParseError
n (ParseContext -> Element
currentElement ParseContext
ctx))
  mapM (withElement parser) introspectableChildren
      where introspectable :: Element -> Bool
            introspectable :: Element -> Bool
introspectable Element
e = Name -> Element -> Maybe ParseError
lookupAttr Name
"introspectable" Element
e Maybe ParseError -> Maybe ParseError -> Bool
forall a. Eq a => a -> a -> Bool
/= ParseError -> Maybe ParseError
forall a. a -> Maybe a
Just ParseError
"0" Bool -> Bool -> Bool
&&
                               Name -> Element -> Maybe ParseError
lookupAttr Name
"shadowed-by" Element
e Maybe ParseError -> Maybe ParseError -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe ParseError
forall a. Maybe a
Nothing

-- | Parse all subelements with the given local name.
parseAllChildrenWithLocalName :: Text -> Parser a -> Parser [a]
parseAllChildrenWithLocalName :: forall a. ParseError -> Parser a -> Parser [a]
parseAllChildrenWithLocalName ParseError
n Parser a
parser = do
  ctx <- ReaderT ParseContext (Except ParseError) ParseContext
forall r (m :: * -> *). MonadReader r m => m r
ask
  mapM (withElement parser) (childElemsWithLocalName n (currentElement ctx))

-- | Parse all introspectable children with the given namespace and
-- local name.
parseChildrenWithNSName :: GIRXMLNamespace -> Text -> Parser a -> Parser [a]
parseChildrenWithNSName :: forall a. GIRXMLNamespace -> ParseError -> Parser a -> Parser [a]
parseChildrenWithNSName GIRXMLNamespace
ns ParseError
n Parser a
parser = do
  ctx <- ReaderT ParseContext (Except ParseError) ParseContext
forall r (m :: * -> *). MonadReader r m => m r
ask
  let introspectableChildren = (Element -> Bool) -> [Element] -> [Element]
forall a. (a -> Bool) -> [a] -> [a]
filter Element -> Bool
introspectable
                               (GIRXMLNamespace -> ParseError -> Element -> [Element]
childElemsWithNSName GIRXMLNamespace
ns ParseError
n (ParseContext -> Element
currentElement ParseContext
ctx))
  mapM (withElement parser) introspectableChildren
      where introspectable :: Element -> Bool
            introspectable :: Element -> Bool
introspectable Element
e = Name -> Element -> Maybe ParseError
lookupAttr Name
"introspectable" Element
e Maybe ParseError -> Maybe ParseError -> Bool
forall a. Eq a => a -> a -> Bool
/= ParseError -> Maybe ParseError
forall a. a -> Maybe a
Just ParseError
"0"

-- | Run the given parser for a given subelement in the XML tree.
withElement :: Parser a -> Element -> Parser a
withElement :: forall a. Parser a -> Element -> Parser a
withElement Parser a
parser Element
element = (ParseContext -> ParseContext) -> Parser a -> Parser a
forall a.
(ParseContext -> ParseContext)
-> ReaderT ParseContext (Except ParseError) a
-> ReaderT ParseContext (Except ParseError) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ParseContext -> ParseContext
modifyParsePosition Parser a
parser
    where modifyParsePosition :: ParseContext -> ParseContext
modifyParsePosition ParseContext
ctx =
              ParseContext
ctx { treePosition = elementDescription element : treePosition ctx
                  , currentElement = element}

-- | Run the given parser, returning either success or an error.
runParser :: Text -> M.Map Alias Type -> Element -> Parser a ->
             Either ParseError a
runParser :: forall a.
ParseError
-> Map Alias Type -> Element -> Parser a -> Either ParseError a
runParser ParseError
ns Map Alias Type
aliases Element
element Parser a
parser =
    Except ParseError a -> Either ParseError a
forall e a. Except e a -> Either e a
runExcept (Parser a -> ParseContext -> Except ParseError a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Parser a
parser ParseContext
ctx)
              where ctx :: ParseContext
ctx = ParseContext {
                            ctxNamespace :: ParseError
ctxNamespace = ParseError
ns
                          , treePosition :: [ParseError]
treePosition = [Element -> ParseError
elementDescription Element
element]
                          , currentElement :: Element
currentElement = Element
element
                          , knownAliases :: Map Alias Type
knownAliases = Map Alias Type
aliases
                          }