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
, 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)
data ParseContext = ParseContext {
ParseContext -> ParseError
ctxNamespace :: Text,
ParseContext -> [ParseError]
treePosition :: [Text],
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
type ParseError = Text
type Parser a = ReaderT ParseContext (Except ParseError) a
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
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
"]"
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
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
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
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
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."
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."
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)
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)
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
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"
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
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)
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)
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
"\"."
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)
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
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))
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"
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}
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
}