-- | 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
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 :: forall a. ParseError -> Parser a
parseError ParseError
msg = do
  ParseContext
ctx <- forall r (m :: * -> *). MonadReader r m => m r
ask
  let position :: ParseError
position = (ParseError -> [ParseError] -> ParseError
T.intercalate ParseError
" / " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseContext -> [ParseError]
treePosition) ParseContext
ctx
  forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ ParseError
"Error when parsing \"" forall a. Semigroup a => a -> a -> a
<> ParseError
position forall a. Semigroup a => a -> a -> a
<> ParseError
"\": " forall a. Semigroup a => a -> a -> a
<> ParseError
msg forall a. Semigroup a => a -> a -> a
<> ParseError
"\n"
                 forall a. Semigroup a => a -> a -> a
<> (String -> ParseError
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
ppShow 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 -> ParseError
elementDescription Element
element =
    case 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 forall a. Semigroup a => a -> a -> a
<> ParseError
" [" forall a. Semigroup a => a -> a -> a
<> ParseError
n 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
  ParseContext
ctx <- forall r (m :: * -> *). MonadReader r m => m r
ask
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ParseError -> ParseError -> Name
Name (ParseContext -> ParseError
ctxNamespace ParseContext
ctx) ParseError
n

-- | Return the current namespace.
currentNamespace :: Parser Text
currentNamespace :: Parser ParseError
currentNamespace = ParseContext -> ParseError
ctxNamespace forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
  ParseContext
ctx <- forall r (m :: * -> *). MonadReader r m => m r
ask
  case 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 Name
n) -> Name -> Parser Type
resolveQualifiedTypeName Name
n
    Just Type
t -> forall (m :: * -> *) a. Monad m => a -> m a
return Type
t
    Maybe Type
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return 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
  ParseContext
ctx <- forall r (m :: * -> *). MonadReader r m => m r
ask
  case Name -> Element -> Maybe ParseError
lookupAttr Name
attr (ParseContext -> Element
currentElement ParseContext
ctx) of
    Just ParseError
val -> forall (m :: * -> *) a. Monad m => a -> m a
return ParseError
val
    Maybe ParseError
Nothing -> forall a. ParseError -> Parser a
parseError forall a b. (a -> b) -> a -> b
$ ParseError
"Expected attribute \"" forall a. Semigroup a => a -> a -> a
<>
               (String -> ParseError
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) Name
attr 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
  ParseContext
ctx <- forall r (m :: * -> *). MonadReader r m => m r
ask
  case GIRXMLNamespace -> Name -> Element -> Maybe ParseError
lookupAttrWithNamespace GIRXMLNamespace
ns Name
attr (ParseContext -> Element
currentElement ParseContext
ctx) of
    Just ParseError
val -> forall (m :: * -> *) a. Monad m => a -> m a
return ParseError
val
    Maybe ParseError
Nothing -> forall a. ParseError -> Parser a
parseError forall a b. (a -> b) -> a -> b
$ ParseError
"Expected attribute \"" forall a. Semigroup a => a -> a -> a
<>
               (String -> ParseError
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) Name
attr forall a. Semigroup a => a -> a -> a
<> ParseError
"\" in namespace \"" forall a. Semigroup a => a -> a -> a
<>
               (String -> ParseError
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) GIRXMLNamespace
ns 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
  ParseContext
ctx <- forall r (m :: * -> *). MonadReader r m => m r
ask
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> Element -> Maybe ParseError
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 ParseError)
queryAttrWithNamespace GIRXMLNamespace
ns Name
attr = do
  ParseContext
ctx <- forall r (m :: * -> *). MonadReader r m => m r
ask
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ GIRXMLNamespace -> Name -> Element -> Maybe ParseError
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 :: 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 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 -> 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 (forall a. Eq a => a -> a -> Bool
== Char
'.') ParseError
n of
    [ParseError
ns, ParseError
name] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ParseError -> ParseError -> Name
Name ParseError
ns ParseError
name
    [ParseError
name] -> ParseError -> Parser Name
nameInCurrentNS ParseError
name
    [ParseError]
_ -> 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" 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
  ParseContext
ctx <- forall r (m :: * -> *). MonadReader r m => m r
ask
  forall (m :: * -> *) a. Monad m => a -> m a
return 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 <- forall r (m :: * -> *). MonadReader r m => m r
ask
  forall (m :: * -> *) a. Monad m => a -> m a
return 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 :: forall a. Integral a => ParseError -> Parser a
parseIntegral ParseError
str =
    case forall a. Num a => Reader a -> Reader a
TR.signed forall a. Integral a => Reader a
TR.decimal ParseError
str of
      Right (a
n, ParseError
r) | ParseError -> Bool
T.null ParseError
r -> forall (m :: * -> *) a. Monad m => a -> m a
return a
n
      Either String (a, ParseError)
_ -> forall a. ParseError -> Parser a
parseError forall a b. (a -> b) -> a -> b
$ ParseError
"Could not parse integral value: \"" forall a. Semigroup a => a -> a -> a
<> ParseError
str 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" = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
parseBool ParseError
"1" = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
parseBool ParseError
other = forall a. ParseError -> Parser a
parseError forall a b. (a -> b) -> a -> b
$ ParseError
"Unsupported boolean value: " forall a. Semigroup a => a -> a -> a
<> String -> ParseError
T.pack (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
  ParseContext
ctx <- forall r (m :: * -> *). MonadReader r m => m r
ask
  let introspectableChildren :: [Element]
introspectableChildren = forall a. (a -> Bool) -> [a] -> [a]
filter Element -> Bool
introspectable
                               (ParseError -> Element -> [Element]
childElemsWithLocalName ParseError
n (ParseContext -> Element
currentElement ParseContext
ctx))
  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a. Parser a -> Element -> Parser a
withElement Parser a
parser) [Element]
introspectableChildren
      where introspectable :: Element -> Bool
            introspectable :: Element -> Bool
introspectable Element
e = Name -> Element -> Maybe ParseError
lookupAttr Name
"introspectable" Element
e forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just ParseError
"0" Bool -> Bool -> Bool
&&
                               Name -> Element -> Maybe ParseError
lookupAttr Name
"shadowed-by" Element
e forall a. Eq a => a -> a -> Bool
== 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
  ParseContext
ctx <- forall r (m :: * -> *). MonadReader r m => m r
ask
  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a. Parser a -> Element -> Parser a
withElement Parser a
parser) (ParseError -> Element -> [Element]
childElemsWithLocalName ParseError
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 :: forall a. GIRXMLNamespace -> ParseError -> Parser a -> Parser [a]
parseChildrenWithNSName GIRXMLNamespace
ns ParseError
n Parser a
parser = do
  ParseContext
ctx <- forall r (m :: * -> *). MonadReader r m => m r
ask
  let introspectableChildren :: [Element]
introspectableChildren = forall a. (a -> Bool) -> [a] -> [a]
filter Element -> Bool
introspectable
                               (GIRXMLNamespace -> ParseError -> Element -> [Element]
childElemsWithNSName GIRXMLNamespace
ns ParseError
n (ParseContext -> Element
currentElement ParseContext
ctx))
  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a. Parser a -> Element -> Parser a
withElement Parser a
parser) [Element]
introspectableChildren
      where introspectable :: Element -> Bool
            introspectable :: Element -> Bool
introspectable Element
e = Name -> Element -> Maybe ParseError
lookupAttr Name
"introspectable" Element
e forall a. Eq a => a -> a -> Bool
/= 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 = 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 :: [ParseError]
treePosition = Element -> ParseError
elementDescription Element
element forall a. a -> [a] -> [a]
: ParseContext -> [ParseError]
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 :: forall a.
ParseError
-> Map Alias Type -> Element -> Parser a -> Either ParseError a
runParser ParseError
ns Map Alias Type
aliases Element
element Parser a
parser =
    forall e a. Except e a -> Either e a
runExcept (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
                          }