-- | The Parser monad.
module Data.GI.GIR.Parser
    ( Parser
    , 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 -> Text
ctxNamespace     :: Text,
      -- Location in the XML tree of the node being parsed (for
      -- debugging purposes).
      ParseContext -> [Text]
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
showList :: [ParseContext] -> ShowS
$cshowList :: [ParseContext] -> ShowS
show :: ParseContext -> String
$cshow :: ParseContext -> String
showsPrec :: Int -> ParseContext -> ShowS
$cshowsPrec :: Int -> 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 :: Text -> Parser a
parseError msg :: Text
msg = do
  ParseContext
ctx <- ReaderT ParseContext (Except Text) ParseContext
forall r (m :: * -> *). MonadReader r m => m r
ask
  let position :: Text
position = (Text -> [Text] -> Text
T.intercalate " / " ([Text] -> Text)
-> (ParseContext -> [Text]) -> ParseContext -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
forall a. [a] -> [a]
reverse ([Text] -> [Text])
-> (ParseContext -> [Text]) -> ParseContext -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseContext -> [Text]
treePosition) ParseContext
ctx
  Text -> Parser a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> Parser a) -> Text -> Parser a
forall a b. (a -> b) -> a -> b
$ "Error when parsing \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
position Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\n"
                 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text)
-> (ParseContext -> String) -> ParseContext -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> String
forall a. Show a => a -> String
ppShow (Element -> String)
-> (ParseContext -> Element) -> ParseContext -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseContext -> Element
currentElement) ParseContext
ctx

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

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

-- | Return the current namespace.
currentNamespace :: Parser Text
currentNamespace :: Parser Text
currentNamespace = ParseContext -> Text
ctxNamespace (ParseContext -> Text)
-> ReaderT ParseContext (Except Text) ParseContext -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT ParseContext (Except Text) 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
name = do
  ParseContext
ctx <- ReaderT ParseContext (Except Text) ParseContext
forall r (m :: * -> *). MonadReader r m => m r
ask
  case Alias -> Map Alias Type -> Maybe Type
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Name -> Alias
Alias Name
name) (ParseContext -> Map Alias Type
knownAliases ParseContext
ctx) of
    -- The resolved type may be an alias itself, like for
    -- Gtk.Allocation -> Gdk.Rectangle -> cairo.RectangleInt
    Just (TInterface n :: Name
n) -> Name -> Parser Type
resolveQualifiedTypeName Name
n
    Just t :: Type
t -> Type -> Parser Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t
    Nothing -> Type -> Parser Type
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 Text
getAttr attr :: Name
attr = do
  ParseContext
ctx <- ReaderT ParseContext (Except Text) ParseContext
forall r (m :: * -> *). MonadReader r m => m r
ask
  case Name -> Element -> Maybe Text
lookupAttr Name
attr (ParseContext -> Element
currentElement ParseContext
ctx) of
    Just val :: Text
val -> Text -> Parser Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
val
    Nothing -> Text -> Parser Text
forall a. Text -> Parser a
parseError (Text -> Parser Text) -> Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ "Expected attribute \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
               (String -> Text
T.pack (String -> Text) -> (Name -> String) -> Name -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
forall a. Show a => a -> String
show) Name
attr Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\" not present."

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

-- | Like `queryAttr`, but allow for specifying the namespace.
queryAttrWithNamespace :: GIRXMLNamespace -> XML.Name -> Parser (Maybe Text)
queryAttrWithNamespace :: GIRXMLNamespace -> Name -> Parser (Maybe Text)
queryAttrWithNamespace ns :: GIRXMLNamespace
ns attr :: Name
attr = do
  ParseContext
ctx <- ReaderT ParseContext (Except Text) ParseContext
forall r (m :: * -> *). MonadReader r m => m r
ask
  Maybe Text -> Parser (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text -> Parser (Maybe Text))
-> Maybe Text -> Parser (Maybe Text)
forall a b. (a -> b) -> a -> b
$ GIRXMLNamespace -> Name -> Element -> Maybe Text
lookupAttrWithNamespace GIRXMLNamespace
ns Name
attr (ParseContext -> Element
currentElement ParseContext
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 :: Name -> a -> (Text -> Parser a) -> Parser a
optionalAttr attr :: Name
attr def :: a
def parser :: Text -> Parser a
parser =
    Name -> Parser (Maybe Text)
queryAttr Name
attr Parser (Maybe Text) -> (Maybe Text -> Parser a) -> Parser a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Just a :: Text
a -> Text -> Parser a
parser Text
a
              Nothing -> a -> Parser 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 :: Text -> Parser Name
qualifyName n :: Text
n = case (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '.') Text
n of
    [ns :: Text
ns, name :: Text
name] -> Name -> Parser Name
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Parser Name) -> Name -> Parser Name
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Name
Name Text
ns Text
name
    [name :: Text
name] -> Text -> Parser Name
nameInCurrentNS Text
name
    _ -> Text -> Parser Name
forall a. Text -> Parser a
parseError "Could not understand name"

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

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

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

-- | Parse a signed integral number.
parseIntegral :: Integral a => Text -> Parser a
parseIntegral :: Text -> Parser a
parseIntegral str :: Text
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 Text
str of
      Right (n :: a
n, r :: Text
r) | Text -> Bool
T.null Text
r -> a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return a
n
      _ -> Text -> Parser a
forall a. Text -> Parser a
parseError (Text -> Parser a) -> Text -> Parser a
forall a b. (a -> b) -> a -> b
$ "Could not parse integral value: \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
str Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\"."

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

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

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

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

-- | Run the given parser for a given subelement in the XML tree.
withElement :: Parser a -> Element -> Parser a
withElement :: Parser a -> Element -> Parser a
withElement parser :: Parser a
parser element :: Element
element = (ParseContext -> ParseContext) -> Parser a -> Parser 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 ctx :: ParseContext
ctx =
              ParseContext
ctx { treePosition :: [Text]
treePosition = Element -> Text
elementDescription Element
element Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: ParseContext -> [Text]
treePosition ParseContext
ctx
                  , currentElement :: Element
currentElement = Element
element}

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